Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-06 - decus/20-153/rpgio.mac
There is 1 other file named rpgio.mac in the archive. Click here to see a list.
	TITLE	RPGIO VERSION 2B			
	SUBTTL	PERFORM ALL I/O FOR RPGII OBJECT PROGRAM

;
;	RPGII I/O PACKAGE
;
;	BOB CURRIER
;		WRITTEN AUGUST 13 IN THE YEAR OF OUR LORD 1975, 23:39:58
;
;	THIS IS THE UNIVERSAL I/O PACKAGE FOR RPGLIB. IT IS IN THIS
;	PACKAGE THAT ALL I/O IS DONE FOR THE OBJECT PROGRAM.
;
;	THE FOLLOWING FEATURES ARE NOT IMPLEMENTED IN THIS VERSION:
;		1) EBCDIC FILE TRANSLATION
;
;	Copyright (C) 1975, 1976 Robert Currier and Cerritos College
;	All rights reserved.
;

	VERSION==3
	MINOR==0
	EDIT==201
	WHO==0

	TWOSEG

	SEARCH RPGSWI, MACTEN, UUOSYM, INTERM, RPGPRM, COMUNI, FTDEFS

	%%COMU==:%%COMU
	%%FTDF==:%%FTDF
	%%LBLP==:%%LBLP

	INFIX%

	LOC	137			; .JBVER

	<WHO>B2+<VERSION>B11+<MINOR>B17+EDIT

	LIBSW%==:LIBSW%
	STATS==:STATS
	DEBUG==:DEBUG

	RELOC	400000			; WE'RE A HISEG

	ENTRY	XFIL			; FILE I/O ROUTINE
	ENTRY	DEATH			; FATAL ERROR ENTRY
	ENTRY	RESET.			; RESET ALL DEVICES
	ENTRY	INPT			; UNIVERSAL INPUT ROUTINE
	ENTRY	OUTPT			; UNIVERSAL OUTPUT ROUTINE
	ENTRY	PPOUT			; DUMP TD ONTO TERMINAL
	ENTRY	GTDATE			; SET UP DATE
	ENTRY	EXCPT.			; Perform exception output UUO
	ENTRY	.READ.			; Perform READ UUO
	ENTRY	CHAIN.			; Perform CHAIN UUO
	ENTRY	HLTOPT			; Perform error handling
	ENTRY	H.99			; Standard halt routine
	ENTRY	TIME.			; get time
	ENTRY	TIMED.			; get time and date
	ENTRY	RSVWD.			; handle a reserved word
	ENTRY	SPOUT			; space on printer/console

	INTERN	XFILW1, XFILW2

	SALL
;DEFINE ALL SORTS OF STUFF
;
;		"When  I use a word," Humpty Dumpty said,
;	in a rather scornful tone, "it means just what 
;	I choose it to mean - neither more nor less."
;
;					Lewis Carrol
;
;
;DEFINE ACCUMULATORS

SW==0					; GENERAL FLAGS
AC0==0					; used by CBLIO linking routines
AC1==1					; USED BY OBJECT PROGRAM
AC2==2					; USED BY OBJECT PROGRAM
AC3==3					; USED BY OBJECT PROGRAM
TA==4					; TEMP
AC4==4					; CBLIO interface
TB==5					; TEMP
AC5==5					; CBLIO interface
TC==6					; TEMP
CNTA==6					; counter for array routines
TD==7					; TEMP
FLG==7					; CBLIO interface
CNTR==7					; counter for array routines
TE==10					; TEMP
TF==11					; TEMP
AC11==11				; CBLIO interface
TG==12					; TEMP
CH==13					; I/O CHARACTER
AC14==14				; General purpose
PA==16					; OP POINTER
AC16==16				; general purpose
PP==17					; PUSHDOWN POINTER

;DEFINE FILE DRIVER LOCS

CHN==:0					; CHANNEL ASSIGNMENT
BLK==:1					; BLOCKING FACTOR
CUR==:2					; CURRENT BLOCK IN BUFFER
PNT==:3					; SIXBIT BYTE POINTER
KEY==:4					; RELKEY FOR NEXT XGET
RWF==:5					; REWRITE FLAG
BSZ==:6					; BUFFER SIZE IN WORDS
BUF==:7					; BASE OF I/O BUFFER
BCN==:10				; BYTE COUNT IN CURRENT BUFFER
EOF==:11				; THIS FILE IS AT EOF
UPD==:12				; UPDATE KEY
LIN==:17				; LINE COUNTER
IPC==:20				; INPUT CHAIN POINTER
SEQ==:21				; SEQUENCE NUMBER
RII==:22				; RECORD IDENTIFYING INDICATOR

;DEFINE MISC CONSTANTS

PPSIZE==200

CHNSIZ==:23				; SIZE OF CHNTAB ENTRY

;DEFINE CARRIAGE CONTROL CHARACTERS

$FF=14					; TOP OF FORM
$CR=15					; NO SPACING
$LF=12					; SINGLE SPACE WITH AUTO FF
$DC1=21					; DOUBLE SPACE WITH AUTO FF
$DC2=22					; TRIPLE SPACE WITH AUTO FF
$DC3=23					; SINGLE SPACE
$DC4=24					; SPACE 1/6 OF PAGE
$VT=13					; SPACE 1/3 OF PAGE
$DLE=20					; SPACE 1/2 OF PAGE


;DEFINE MONITOR CONSTANTS

IO.IMP==1B18
IO.DER==1B19
IO.DTE==1B20
IO.BKT==1B21
IO.EOF==1B22
IO.ACT==1B23
IO.SYN==1B30
IO.UWC==1B31

$BIN==1B23				; DEVICE CAN WRITE BINARY

$OUT==1					; DEVICE CAN DO OUTPUT
$IN==2					; DEVICE CAN DO INPUT
$DIREC==4				; DEVICE HAS A DIRECTORY
$TTY==10				; DEVICE IS A TTY
$MTA==100				; DEVICE IS A MAG-TAPE
$DTA==100				; DEVICE IS A DEC-TAPE
$LPT==40000				; DEVICE IS A LINE-PRINTER
$CDR==100000				; DEVICE IS A CARD-READER
$DSK==200000				; DEVICE IS A DISK
$AVAIL==40				; DEVICE IS AVAILABLE
$CONSL==10000				; DEVICE IS A CONSOLE

$REW==2					; REWIND MAG-TAPE
$ERAS==740000				; DEVICE ERROR FLAGS
$EOT==2000				; END OF MAG-TAPE


.GTCNF==11				; CONFIGURATION TABLE
%CNYER==56				; LOCYER
%CNMON==57				; LOCMON
%CNDAY==60				; LOCDAY
%CNHOR==61				; LOCHOR
%CNMIN==62				; LOCMIN
%CNSEC==63				; LOCSEC
;Define Constants from CBLIO

ATEND==2000				; file has taken "AT-END" path
D.OBB==-10				; output buffer byte pointer
D.DC==-1				; device characteristics
D.LBN==-32				; last device table entry
F.WFLG==10				; flags and buffer address
OPNIN==20000			; file is open for input
OPNOUT==10000				; file is open for output



;Define some useful MACRO's

DEFINE	SPUSH(..A),<
		  XLIST
		IRP ..A <
		PUSH	PP,..A
		>
		  LIST
		>

DEFINE	SPOP(..A),<
		  XLIST
		IRP ..A <
		POP	PP,..A
		>
		  LIST
		>
;
;	EDIT HISTORY
;
;	ALL EDITS SHOULD BE RECORDED HERE, TO KEEP ALL THINGS
;	STRAIGHT. ALL EDITS TO ANY PART OF RPGLIB ARE TO BE 
;	RECORDED HERE IN RPGIO.
;
;


;[201]	15-Feb-79 22:12:36	Attempt to fix PDL overflow on DOVPDL by scanning
;				the DOV PDL to see if indicator is already on stack
;				prior to stacking it.
;[200]	4-Feb-79 13:48:47	Fix total time header output by not restricting
;				it to overflow.
;[177]	4-Feb-79 13:38:42	Fix persistant PDL overflow problem by correcting
;				typo in RPGMAN. (MOVE => MOVEM)
;[176]	22-Jan-78 22:42:54	Add secondary overflow indicators to make things
;				work according to IBM spec
;[175]	10-Jan-78 2:12:38	Finish edit 174
;[174]	5-Jan-78 11:47:12	Fix problems with overflow indicators
;				in detail section
;[173]	4-Jan-78 11:42:04	Fix problems with FETCHed overflow by moving
;				flag reset in OU.08B of RPGIO
;[172]	28-AUG-77 22:48:38	FIX MOVE BY REDEFING SOME AC'S IN MOVE.MAC
;[171]	10-Aug-77 23:22:49	Fix edit 170 by implementing write with no advancing in
;				XFIL. Also change OU.08C to make use of it.
;[170]	6-Aug-77 23:28:49	Fix CBLIO at WRTRE2 by removing %%RPG conditional
;				so we output LF as well as CR on ASCII files.
;[167]	6-Aug-77 21:50:28	Fix FLOT.2 in SQRT to properly float things
;[166]	27-July-77 21:47:32	Fix CKIND to work properly with edit 147.
;[165]	3-July-77 00:56:13	Modified DATAV. in RPGMAN so array items get properly
;				moved from the record buffer. (DJJ)
;[164]	29-June-77 22:46:39	Deleted an obsolete and memory mangling instruction at
;				OU.10+2 in RPGIO. Also deleted an EXTERN reference
;				to it in RPGMAN. (DJJ)
;[163]	3-July-77 00:42:31	Fixed DEBUG so DEBUG op with no factor 1 or result
;				will print out indicators instead of header only. (DJJ)
;[162]	25-Mar-77 14:58:14	Edit 162 deleted in favor of edit 125. (DJJ)
;[161]	3-July-77 00:27:48	Correct compare instruction in RPGMAN so field indicator
;				will be set. Also install code to turn off indicators
;				before testing field. (DJJ)
;[160]				Replaced by Edit 130.
;[150]-[157]			Reserved.
;[147]	2-July-77 23:47:29	Add code to CKIND in RPGIO to support space/skip entries
;				on OR lines. Depends on compiler edit 357.
;[146]	29-June-77 21:45:30	Fix floating dollar sign code in EDIT.
;[145]	6-June-77 02:01:58	Fix edit 137 to do what it was intended to do.
;				Also fix OU.11 to make it set up pointers properly.
;[144]	6-June-77 00:15:28	Add code to CHAIN. to store update key
;[143]	5-June-77 01:07:13	Fix DIV.22 in DPDIV to output remainder properly and
;				avoid overlaying quotient.
;[142]	27-May-77 00:50:40	Modify EDIT to handle zero balance properly for
;				edit codes.
;[141]	26-May-77 01:54:23	Change the way we determine whether or not to do total
;				output in RPGMAN, to make it work for all cases.
;[140]	26-May-77 00:04:17	Make additional fixes to EDIT to support
;				whole array editing properly.
;[137]	22-May-77 19:55:37	Add code to OUTPT in RPGIO to check for chained output
;				files before going thru all that code.
;[136]	15-May-77 23:11:47	Change look-ahead field code to work properly.
;				Add field BINRED to COMUNI to support this.
;[135]	14-May-77 00:25:14	Change .EDTAB in EDIT to correct some of the
;				consequences of edit 133.
;[134]	13-May-77 01:10:02	Fix EXCPT. to zero out the switch register before
;				calling OUTPT.
;[133]	10-May-77 00:37:01	Fix EDIT to properly set up index for output arrays
;[132]	3-May-77 00:32:25	Fix EDIT to properly work with whole arrays and
;				edit codes.
;[131]	14-Apr-77 22:06:51	Fix fetched overflow code in RPGIO. Note that
;				this requires some changes to the overflow handleing
;				code which may cause some problems.
;[130]	2-Apr-77 02:41:37	Fix non-numeric compare by removing odd AC redefinition
;				in COMP. This will probably cause other problems
;				later, but doesn't seem to now. This is David Joel's
;				edit 160.
;[127]	2-Apr-77 02:04:13	Fix edit 124 by moving zero fill test to proper
;				place. We were suppressing decimal points instead.
;				Edit at EDC.6+1 in EDIT.MAC
;[126]	1-Apr-77 15:36:04	Fix .READ. in RPGIO to correctly restore PA so
;				that we turn on/off proper indicator. This was cause
;				of mem prot vio.
;[125]	28-Mar-77 00:00:23	Fix RPGMAN to properly turn on lower level control
;				indicators on a control break. Fix at C.06H+2.
;[124]	17-Mar-77 22:34:28	Fix bad editing for edit code 1 and others like
;				it. This also fixes bad zero balance editing. Changes in
;				EDIT.MAC at EDC.6 and .EDIT4-2
;[123]	7-Mar-77 22:31:52	Add code to EDIT to make floating dollar sign and
;				asterisk fill work properly with edit codes.
;[122]	7-Mar-77 01:01:19	Fix endless loop in EDIT by making routine JRST to
;				the correct place. Changed module EDIT.
;[121]	19-Feb-77 02:33:03	Fix SKOUT in RPGIO to properly output form feeds. Also
;				remove useless instruction at IN.00-1 in RPGIO.
;[120]	12-Feb-77 20:16:54	Fix C.05G in RPGMAN to handle files at EOF
;[117]	27-Jan-77 22:50:07	Fix RSTARR to reset OT.BFP in new
;				OTFTAB.
;[116]	25-Jan-77 14:29:57	Add code to RSTARR to allow multiple files
;				on CDR:.
;[115]	21-Jan-77 03:42:27	At A.01 in RPGMAN add code to clear SW upon entry
;				from user program.
;[114]	21-Jan-77 00:21:10	Fix MR indicator by rewriting routine C.05 and adding
;				routine .MCHK to RPGMAN.
;[113]	18-Jan-77 19:37:14	Fix C.08 in RPGMAN to turn on L1-L9 along with
;				the LR indicator.
;[112]	9-Jan-77 03:18:57	Add code at .EDARI in EDIT to get subscript into
;				the proper AC.
;[111]	6-Jan-77 22:09:31	Move POP from B.00B to B.00B-1 in RPGMAN to avoid
;				PDL underflow.
;[110]	4-Jan-77 02:49:39	Add protection code for negative subscript to
;				SUBSCR at SUBSCR.
;[107]	2-Jan-77 00:47:13	Remove edit 106.
;[106]	2-Jan-77 00:00:14	Change sequential key code in INPT to use the actual
;				key stored in CBLIO's FILTAB rather than the one in
;				our own CHNTAB.
;[105]	1-Jan-77 23:18:38	Add code to double entries/record if alternating
;				tables are being used at RSTAR2+1 in RPGIO.
;[104]	28-Dec-76 01:04:24	Do what edit 102 was supposed to do by changing XFCLR+3 to
;				use final address - 1 for the BLT.
;[103]	27-Dec-76 22:49:16	Remove edit 102.
;[102]	25-Dec-76 01:31:07	Remove line at XFCLR+6 so that we don't clear the first
;				word of the following buffer.
;[101]	25-Dec-76 00:51:34	Add code at C.05F+6 in RPGMAN to do proper order check
;				when processing matching records.
;[100]	24-Dec-76 20:39:59	Fix C.05J in RPGMAN to check proper AC.
;[077]	24-Dec-76 20:28:07	Clean up code at D.02D in RPGMAN and also fix MR set code
;				to use proper left-over AC.
;[076]	21-Dec-76 02:00:31	Add check for no sequence checking at C.03C+4 in RPGMAN.
;[075]	13-Dec-76 01:21:02	Fix EDC. in EDIT to turn off FSPAC upon entry. This fixes
;				the elusive date shift on physical LPT problem.
;[074]	12-Dec-76 22:55:18	Fix INPT to skip on correct condition when checking for MFCU.
;
;********* %1I(73) Limited Release Edition **********
;
;********* %1H(73) Limited Release Edition **********
;[073]	18-Nov-76 00:14:43	Add edit flag 5 to EDIT to support special case of
;				initial zero with extra edit position. See related edit
;				in PREDIT of the compiler.
;[072]	13-Nov-76 00:22:54	Fix zero fill editing routine to increment pointer properly
;				at EDIT7C+2 in EDIT.MAC.
;[071]	18-Oct-76 01:18:52	Change CKIND3 to test next word for ID.OR
;[070]	18-Oct-76 00:30:58	Fix code in OUTPT that keeps track of current line
;				number. Also fix SPOUT to update the line number.
;[067]	6-Oct-76 22:31:13	Fix floating dollar code in EDIT at EDIT7E+2
;[066]	30-Sep-76 22:44:41	Fix SUBSC. to pass parameter to GD routines in AC3.
;[065]	30-Sep-76 22:37:28	Fix SUBSC. to PUSH the proper AC.
;[064]	19-Sep-76 21:58:42	Fix CBLIO to properly detect physical CDR when checking
;				for labels on OPEN. Fix at OPNRLB.
;[063]	1-Sep-76 14:51:28	Fix matching record sequence checking code at C.03E
;				in RPGMAN.
;[062]	1-Sep-76 12:46:31	Add header output code to A.01 in RPGMAN.
;[061]	1-Sep-76 11:08:06	Add code to C.04 in RPGMAN to get the proper CHNTAB index.
;				Also add code to B.00 to save the index TG.
;[060]	28-Aug-76 10:12:02	Add register .SVCH as place for PD to stash CH, rather
;				than PUSHing onto stack.
;[057]	23-Aug-76 10:36:18	Add 1P support code to RPGMAN at A.00
;[056]	18-Aug-76 13:09:24	Rewrite GTDATE routine to work on the 20.
;[055]	18-Aug-76 12:31:17	Add DECsystem-20 support code to CBLIO and COMUNI.
;[054]	17-Aug-76 16:58:23	Add MFCU support to RESET. Also add code
;				to test if real or logical LPT in SPOUT and output
;				Line feed or DC3 accordingly.
;[053]	16-Aug-76 13:04:02	Add MFCU support code. Also change SPOUT to output
;				DC3's rather than line-feed's.
;[052]	12-Aug-76 14:44:52	Finish modifying EDIT to handle tables/arrays.
;[051]	11-Aug-76 15:58:14	Modify EDIT to properly handle whole arrays
;				and table entries.
;[050]	5-Aug-76 13:58:24	Do a little clean up work. Also add DDT
;				halt option, and make option scanner accept lower
;				case ok.
;[047]	21-Jul-76 23:49:12	Add RIIPDL code to RPGMAN, RPGIO and COMUNI. This will
;				solve the problem of CHAINed update files never getting
;				their RII cleared.
;[046]	21-Jul-76 16:31:04	Make CHAIN. properly save AC16 on call to INPT so
;				we can recover the error indicator upon return.
;[045]	15-Jul-76 15:49:28	Fix RIIGET to bump INDTAB pointer at the
;				time @ RIIG07+4. This fixes yet another problem with
;				AND/OR lines on output.
;[044]	13-Jul-76 22:03:12	Modify WRITE/REWRITE algorithm in OU.16 to do things
;				the right way.
;[043]	13-Jul-76 19:18:23	Improve the HLTOPT routines by adding alpha option
;				specification and filename output.
;********** %1E(42) Limited Edition Release **********
;
;[042]	5-Jul-76 21:41:20	Add code to RPGIO to handle pre-execution reading
;				of table files.
;[041]	21-Jun-76 01:21:16	Add code to RPGMAN to handle look-ahead fields.
;[040]	15-Jun-76 00:00:12	Add error handlers.
;[037]	14-Jun-76 22:17:31	Add READ. to RPGIO to support the verb.
;[036]	13-Jun-76 04:03:29	Add EXCPT. to RPGIO to support new verb. Also move
;				FRCFIL to fixed area.
;[035]	7-Jun-76 22:51:52	Replace all I/O routines with new interfaces
;				to CBLIO.
;[034]	6-Jun-76 15:04:23	Start interfacing to CBLIO. Modify RESET
;				routines.
;[033]	29-MAY-76 13:52:28	ADD COMUNI.MAC AND MODIFY RPGIMP.MAC TO USE IT SO
;				WE CAN GET READY TO INTERFACE CBLIO.MAC
;[032]	20-MAY-76 20:44:20	FIX RIIGET IN RPGMAN TO INCREMENT INDTAB POINTER
;				AFTER IT GETS THE ID.OR FLAG
;[031]	20-MAY-76 20:32:29	FIX COMP TO CHECK FOR ZERO INDICATOR BEFORE IT CALLS
;				SINDT.
;[030]	23-APR-76 22:46:18	FIX UUOHAN SO THAT SUBSCR IS UUO1 NOT UUO0
;
;********** %1C(27) LIMITED EDITION RELEASE *********;
;[027]	1-APR-76 21:22:28	ADD ROUTINE CKIND TO RPGIO.MAC AND MODIFY OUTPT
;				TO USE BOTH THIS AND INDC.1
;[026]	23-MAR-76 22:58:28	ADD MOVSGN.MAC TO RPGLIB
;[025]	21-MAR-76 22:02:19	ADD MOVE.MAC AND CDD.MAC TO RPGLIB
;[024]	16-MAR-76 02:31:42	FIX BAD REGISTER ALLOCATION IN DPMUL.MAC
;[023]	12-MAR-76 21:31:42	FIX D.03 IN RPGMAN TO PROPERLY HANDLE INPUT
;				RECORD WITH NO ITEMS.
;[022]	24-FEB-76 22:59:23	TRY SPEEDING UP INDC. ONE MORE TIME
;[021]	22-FEB-76 23:14:76	CLEAN UP INDC. A BIT AND ADD SKIND2 TO
;				TRY TO SPEED THINGS UP A BIT.
;[020]	15-FEB-76 20:14:32	ADD TEMPORARY MESSAGE AT B.01A IN RPGMAN
;				TO LET THE USER KNOW ABOUT UNIDENTIFIABLE
;				RECORDS.
;[017]	15-FEB-76 16:29:52	MODIFY RIIGET IN RPGMAN TO PROPERLY HANDLE
;				A 'NOT' ENTRY FOR RII
;[016]	13-FEB-76 18:55:23	PUT TEMPORARY MOD IN XOPEN IN RPGIO
;				SO THAT IMPATIENT PEOPLE CAN USE DISK FILES
;[015]	23-JAN-76 01:32:36	ADD INDC STATISTICS SO WE CAN SEE IF IT REALLY
;				USES AS MUCH TIME AS WE THINK IT DOES.
;[014]	17-JAN-76 23:45:23	ADD STATISTICS OPTION SO WE CAN DO SOME OPTIMIZATION.
;[013]	17-JAN-76 17:17:37	REMOVE ALL OCCURANCES OF SIXDIG AND USE THE
;				CVTSNM MACRO THAT WE TOOK FROM LIBOL-10.
;[012]	14-JAN-76 22:31:25	FIX Z EDIT CODE IN EDIT.MAC AT EDC.7+6.
;				THE FIRST SPACE IN AN EDIT STRING COUNTS AS A PRINT POSITION.
;[011]	10-JAN-76 22:06:27	NOW THAT WE HAVE LIBOL-10 ADD THE ALPHA COMP
;				ROUTINES. THIS ALSO MEANS ADDITION OF
;				MANY UNIVERSALS (INTERM,RPGPRM,CHREQV,NUMEQV,EASTBL)
;				THIS WILL MAKE IT HARDER TO MAINTAIN BUT
;				WILL MAKE THINGS FASTER.
;[010]	4-JAN-76 16:06:25	MAKE CORRECTION AT OU.00B+3 IN RPGIO SO THAT CURREC
;				IS UPDATED EVEN IF FIRST RECORD FOUND IS VALID.
;[007]	27-DEC-75 19:31:42	REWRITE OU.01C TO PROPERLY HANDLE OVERFLOW LINES.
;
;********** %1(6) LIMITED EDITION RELEASE **********;
;[006]	14-DEC-75 02:31:25	FIX GODDAMN AC DEFINITIONS IN SIXDIG TO WORK RIGHT
;[005]	8-DEC-75 16:21:09	FIX BUG SO THAT A CONTROL BREAK SETS ON THE PROPER
;				CONTROL LEVEL INDICATOR AND ALL THOSE BELOW IT. 
;[004]	30-NOV-75 22:17:32	FIX PROBLEMS WITH OVERFLOW INDICATORS
;				AT OU.08C+34 /RBC
;[003]	25-NOV-75 13:01:16	REDEFINE AC'S IN PD67B AND GD67B TO WORK RIGHT. /RBC
;[002]	6-NOV-75 21:04:32	FIX .EDIT TO PROPERLY HANDLE BLANK AFTER. /RBC
;[001]	6-NOV-75 16:43:59	MODIFY XFCDR TO HANDLE BATCH CARD INPUT
;				WITH "/SUPPRESS" SPECIFIED ON $DATA CARD. /RBC
SUBTTL	XFIL - Universal I/O Routine
;XFIL UNIVERSAL I/O ROUTINE SUBLEVEL 1
;
;WILL READ OR WRITE RECORDS ON ANY RPGII SUPPORTED DEVICE.
;
;ENTER ROUTINE WITH:
;	TA = POINTER TO OTF ENTRY
;	TB = 0 for READ, 1 for WRITE, 2 for REWRITE, or 3 for WRITE with no advancing
;	TF = CHNTAB POINTER OR ZERO
;

XFIL:	PUSH	PP,SW			; save the flags on the stack
	MOVEM	TA,XFOTF		; save for possible later reuse
	JUMPE	TB,XFILR		; off for a read
	LDB	AC16,OT.FTB		; get FTBTAB pointer for CBLIO
	HRLI	AC16,001240		; get write UUO
	LDB	TC,OT.BSC		; get buffer size in characters
	DPB	TC,XFWBYT		; stash in lowseg where we must run
	MOVE	TC,[PUSHJ PP,WADV.##]	; [171] get write with no advancing
	CAIN	TB,3			; [171] is that what we want?
	  JRST	XFILW3			; [171] looks that way
	MOVE	TC,[PUSHJ PP,WRITE.##]	; get default instruction
	CAIE	TB,1			; write?
	  MOVE	TC,[PUSHJ PP,RERIT.##]	; no - use rewrite

XFILW3:	MOVEM	TC,CWRIT.##		; [171] stash as thing to execute
	JRST	CWRIT.			; go execute it

XFILW1:	PUSHJ	PP,XFCLR		; clear out the buffer then exit
	POP	PP,SW			; restore the flags
	POPJ	PP,			; and exit


XFILR:	PUSHJ	PP,XFCLR		; clear out the old
	LDB	AC16,OT.FTB		; get FTBTAB pointer for read UUO
	HRLI	AC16,001200		; get that read UUO
	PUSHJ	PP,READ.##		; and goo do the read
	  JRST	XFILR1			; exit on success
	MOVE	TA,XFOTF		; failure - get OTFTAB pointer to determine why
	LDB	TB,OT.FTB		; get FTBTAB pointer
	MOVE	FLG,F.WFLG(TB)		; get the flags
	TLNN	FLG,ATEND		; are we at end-of-file?
	  JRST	XFILRE			; no - check out the error
XFILR2:	LDB	TF,OT.CHN		; yes - get the pseudo-channel
	IMULI	TF,CHNSIZ		; time size of CHNTAB entry
	ADD	TF,CHNBAS		; plus base location
	SETOM	EOF(TF)			; set the EOF flag

XFILR1:	POP	PP,SW			; restore the flags
	AOS	(PP)			; take ok exit
	POPJ	PP,			; exit

XFWBYT:	POINT	12,CWSIZ.##,11		; pointer to buffer size for write op
;XFIL (cont'd)
;
;
;XFCLR		Routine to clear out file buffer
;
;
;

XFCLR:	MOVE	TA,XFOTF		; make sure we recover pointer
	LDB	TB,OT.BFP		; get pointer to buffer
	LDB	TC,OT.BSZ		; get size of buffer
	ADDI	TC,-1(TB)		; [104] get end of buffer
	HRLS	TB			; make a BLT pointer
	SETZM	(TB)			; zap the furst word
	ADDI	TB,1			; set up by one
	BLT	TB,(TC)			; kill the buffer
	POPJ	PP,			; exit


;XFILRE		Process READ error
;
;
;

XFILRE:	LDB	TC,OT.PRO		; get processing mode
	CAIE	TC,2			; sequential by key?
	  JUMPN	TC,XFILW1+1		; no - if not consecutive, then jump
	MOVE	TB,FS.FS##		; yes - get file status
	CAIE	TB,^D10			; is error "no next logical record"?
	  JRST	XFILW1+1		; no - just plain error
	JRST	XFILR2			; yes - treat as EOF


;XFILW2		Process WRITE error
;
;
;

XFILW2:	MOVE	TB,FS.FS		; get file status
	CAIE	TB,^D22			; duplicate key?
	  JRST	XFIW21			; no -
	PUSHJ	PP,%%H.1H		; yes -
	JRST	XFILW1+1		; continue

XFIW21:	PUSHJ	PP,%%H.1U		; general error
	JRST	XFILW1+1		; continue
;WE NOW HAVE THE BASIC ROUTINES SET UP, NEXT COMES THE LEVEL THAT
;THE MAIN LIBRARY TALKS TO.
;
;
;	"And when this History was done there followed
;	it another. A Romance involving the same participants
;	in experiences perhaps even more bizzare and awesome
;	than the last."
;
;				The Chronicles of Castle Brass
;
;
SUBTTL	INPT - Input routine

;INPT		Input I/O Routine
;
;This is the routine which handles the input from various types of files. It is
;left up to the other routines to do the file selection; all this routine does
;is read the next logical record from the specified file. It assumes that the
;following AC's are set up:
;
;		TA = OTFTAB pointer
;		TF = CHNTAB pointer
;

INPT:	MOVEM	TF,CURCHN		; save for later use after TF gets messed over
	LDB	TC,OT.DEV		; get device
	CAIG	TC,1			; [074] MFCU?
	  JRST	IN.03			; yes -
	LDB	TC,OT.ORG		; get the files organization
	CAIN	TC,2			; indexed?
	  JRST	IN.01			; yes - go handle
	LDB	TC,OT.PRO		; no - get the processing mode
	CAIN	TC,1			; addrout?
	  JRST	IN.02			; yes - 
	AOS	TB,KEY(TF)		; no - must be sequential so get the next key
;[121]	LDB	TC,OT.FTB		; [106
IN.00:	LDB	TC,OT.FTB		; get pointer into FTBTAB
	HRRZ	TC,F.RACK(TC)		; get pointer to actual key
	SKIPE	TC			; is there one?
	  MOVEM	TB,(TC)			; yes - save the key where CBLIO can get it
IN.01:	SETZ	TB,			; flag as read
	PUSHJ	PP,XFIL			; go do the actual read
	  POPJ	PP,			; take invalid key return
	MOVE	TA,CUROTF		; get back the OTFTAB pointer
	MOVE	TF,CURCHN		; get back the CHNTAB pointer too
	LDB	TC,OT.TYP		; get the type of file
	CAIE	TC,2			; update?
	  JRST	RET.2##			; no - take OK exit
	LDB	TB,OT.ORG		; get file organization
	CAIN	TB,2			; indexed?
	  JRST	IN.01A			; yes -
	MOVE	TC,KEY(TF)		; yes - get the key back
	MOVEM	TC,UPD(TF)		; and stash as update key
	JRST	RET.2			; take OK return

IN.01A:	LDB	TB,OT.FTB		; get FTBTAB pointer
	MOVE	TB,F.WBSK(TB)		; get byte pointer to symbolic key
	MOVE	TC,[POINT 6,UPD(TF)]	; get pointer to update key storage
	LDB	TD,OT.KYL		; get key length
	ILDB	CH,TB			; get char from symbolic key
	IDPB	CH,TC			; stash in temp storage
	SOJG	TD,.-2			; loop until done
	JRST	RET.2			; take OK return
;IN.02		Handle ADDRout file
;
;
;

IN.02:	LDB	TA,OT.ADP		; get pointer to ADDRout file
	LDB	TF,OT.CHN		; get it's psuedo channel
	IMULI	TF,CHNSIZ		; times entry size
	ADD	TF,CHNBAS		; plus base address
	AOS	TB,KEY(TF)		; increment key
	LDB	TC,OT.FTB		; get FTBTAB pointer
	HRRZ	TC,F.RACK(TC)		; get pointer to actual key
	SKIPE	TC			; was there one?
	  MOVEM	TB,(TC)			; yes - put key where CBLIO can get to it
	PUSH	PP,TF			; save chntab pointer
	SETZ	TB,			; set up for read
	PUSHJ	PP,XFIL			; go do the read
	  JRST	IN.02B			; take invalid key return
	POP	PP,TF			; get back pointer into chntab
	SKIPE	EOF(TF)			; ADDRout file at EOF?
	  JRST	IN.02A			; yep -
	MOVE	TA,XFOTF		; no - get ADDRout file OTFTAB pointer
	LDB	TB,OT.BFP		; get pointer to record buffer
	HLRZ	TB,(TB)			; get that three byte key
	MOVE	TF,CURCHN		; get the good channel
	MOVEM	TB,KEY(TF)		; save the key
	MOVE	TA,CUROTF		; get that OTFtab pointer
	JRST	IN.00			; and go read master file

IN.02A:	MOVE	TF,CURCHN		; get master file channel pointer
	MOVE	TA,CUROTF		; get master file OTFtab pointer
	SETOM	EOF(TF)			; say it's at EOF
	AOS	(PP)			; successful return
	POPJ	PP,			; thusly

IN.02B:	POP	PP,TC			; pop off extraneous data
	POPJ	PP,			; take invalid key return
;IN.03		Handle MFCU
;
;
;

IN.03:	SETZM	MFLAST##		; default to 1
	SKIPE	TC			; is it 1?
	  SETOM	MFLAST			; no - set to 2
	SKIPN	TB,MFOREC##		; is there stuff in to output record?
	  JRST	IN.03A			; no -
	MOVE	TA,MFOTF##-1(TB)	; get OTFTAB pointer for stacker
	LDB	TF,OT.CHN		; get psuedo-channel
	IMULI	TF,CHNSIZ		; same old routine
	ADD	TF,CHNBAS		; again
	AOS	TB,KEY(TF)		; get new key
	LDB 	TC,OT.FTB		; get FTBTAB pointer
	HRRZ	TC,F.RACK(TC)		; get pointer to actual key
	SKIPE	TC			; skip if there isn't one
	MOVEM	TB,(TC)			; else save it
	MOVEI	TB,1			; get write flag
	PUSHJ	PP,XFIL			; do the write
	SETZM	MFOREC			; start over

IN.03A:	MOVE	TA,CUROTF		; get back pointer
	MOVE	TF,CURCHN		; and another pointer
	JRST	IN.00-1			; go input a record
SUBTTL	OUTPT - Output Routine

;OUTPT		UNIVERSAL OUTPUT ROUTINE
;
;	THIS ROUTINE IS THE HIGH-LEVEL INTERFACE TO THE OUTPUT HALF
;OF THE I/O ROUTINES. DESIGNED TO BE GENERAL PURPOSE, EASY
;TO MAINTAIN AND DOCUMENT, LOOK WHAT IT IS NOW. ACCEPTS THE FOLLOWING
;FLAGS:
;
;	(DEFAULT)	ALL OUTPUT WHOSE INDICATOR REQUIREMENTS ARE MET
;			AND ARE NOT CONDITIONED BY CONTROL LEVEL OR 
;			OVERFLOW INDICATORS
;	OVONLY		ONLY THOSE RECORDS CONDITIONED BY AN OVERFLOW
;			INDICATOR WILL BE OUTPUT.
;	LONLY		ONLY THOSE RECORDS CONDITIONED BY A CONTROL LEVEL
;			INDICATOR WILL BE OUTPUT.
;ON RETURN:
;
;	OVTIM		OVERFLOW HAS OCCURED, AND APPROPRIATE INDICATORS
;			HAVE BEEN SET ON.
;
;AC'S ON ENTRY:
;
;	NO AC'S MUST BE SET UP.
;
;

OUTPT:	MOVE	TA,OTFBAS		; GET START OF OTFTAB
	MOVEM	TA,CUROTF		; STASH

OU.00:	SETZM	.SVIND			; [176] set to null
	LDB	TB,OT.DES		; [137] get file descriptor
	LDB	TC,OT.TYP		; [145] get file type
	CAIN	TB,2			; [137] chained file?
	 CAIN	TC,2			; [145] yes - update also?
	  TRNA				; [145] either not chained or chained update file
	   JRST	OU.04			; [145] chained but not update
	LDB	TF,OT.CHN		; GET CHANNEL
	IMULI	TF,CHNSIZ		; MAKE INTO A POINTER
	ADD	TF,CHNBAS		;

OU.00B:	LDB	TA,OT.OPC		; GET START OF OUTPUT CHAIN
	JUMPE	TA,OU.04		; JUMP IF NO OUTPUT SIDE
	MOVEM	TA,CUROCH		; STORE FOR LATER
	MOVEM	TA,CURREC		; [010] UPDATE CURREC NOW, NEEDED DOWN IN OU.08B

OU.00C:	SWOFF	OVFLG!LFLG;		; start fresh
	LDB	TB,OC.ORT		; get record type
	SKIPN	@ORTAB(TB)		; correct type?
	  JRST	OU.03			; no -
	LDB	TA,OC.IND		; yes - get indicators and fall thru....
;OUTPT	(cont'd)
;
;
;

OU.01:	PUSHJ	PP,CKIND		; SEE IF INDICATORS ARE OK
	  JRST	OU.03			; NO - GET ANOTHER RECORD

OU.01C:	TSWF	OVFLG;			; [131] did we find overflow indicator?
	 TSWT	OVONLY;			; [131] yes - do we want it?
	  TSWT	OVFLG!OVONLY;		; [131] no - are both indicators off?
	   TRNA				; [131] yes - all ok
	    JRST OU.03			; [131] no - we don't want this record
	TSWF	LFLG			; DID WE FIND A CONTROL INDICATOR?
	 TSWF	LONLY			; YES - DO WE WANT IT?
	  JRST	OU.05			; EITHER WE WANT IT OR NO CLI FOUND

OU.03:	TSWF	FRSPEC;			; special call?
	  POPJ	PP,			; yes - exit
	MOVE	TA,CUROCH		; GET NEXT RECORD
	SWOFF	WRITF;			; TURN OFF FLAG
	LDB	TA,OC.NXR		; GET NEXT RECORD LINK
	JUMPE	TA,OU.04		; IF ZERO - GET NEXT FILE
	MOVEM	TA,CUROCH		; STUFF AWAY
	MOVEM	TA,CURREC		; STORE AS CURRENT RECORD
	JRST	OU.00C			; AND LOOP

OU.04:	TSWF	OVONLY;			; [176] are we doing overflow?
	  PUSHJ	PP,OU.03B		; [176] yes - turn off zecondary
	MOVE	TA,CUROTF		; GET NEXT FILE
	TSWF	FOVTIM!FREAD;		; ARE WE PERFORMING FETCHED OVERFLOW?
	  POPJ	PP,			; YES - ONLY ONE FILE
	LDB	TB,OT.LAS		; GET LAST FILE FLAG
	SKIPE	TB			; WERE WE LAST?
	  POPJ	PP,			; YES - EXIT
	ADDI	TA,OTFSIZ		; BUMP POINTER
	MOVEM	TA,CUROTF		; STORE FOR OTHERS
	JRST	OU.00			; AND LOOP

OU.03B:	SKIPN	TA,.SVIND##		; [176] get saved indicator ptr
	  POPJ	PP,			; [176] return if no success
OU.03C:	MOVE	TE,(TA)			; [176] get flags
	LDB	TF,ID.IND		; [176] get indicator
	CAIL	TF,167			; [176] overflow?
	CAILE	TF,176			; [176] ?
	 TRNA				; [176] no -
	  SETZM	.OA##-167(TF)		; [176] yes - clear it
	TRNE	TE,1B22			; [176] is this the end?
	 POPJ	PP,			; [176] yes -
	SKIPGE	1(TA)			; [176] OR line next?
	 POPJ	PP,			; [176] yes -
	AOJA	TA,OU.03C		; [176] no - loop for more
;OU.05		WE NOW HAVE VALID RECORD, TRY TO FIND VALID FIELD
;
;

OU.05:	MOVE	TA,CUROCH		; WE ARE POINTING TO VALID RECORD
	LDB	TA,OC.NXF		; GET POINTER TO NEXT FIELD
	JUMPE	TA,OU.08B		; RAN OUT OF THEM
	MOVEM	TA,CUROCH		; STORE
	LDB	PA,OC.IND		; GET INDICATOR CHAIN
	JUMPE	PA,OU.08		; IF ZERO LINK, ALWAYS OUTPUT
	PUSHJ	PP,INDC.##		; GO CHECK 'EM OUT
	  JRST	OU.05			; NO LUCK, TRY AGAIN


;OU.08		Come here when a valid field is found
;
;
;

OU.08:	PUSHJ	PP,EDIT.		; go edit and move field
	SWON	WRITF;			; say we output at least one field
	JRST	OU.05			; go look for another field
;OU.08B		Come here after we are done with a record
;
;
;

OU.08B:	TSWT	WRITF;			; did we output any fields?
	  JRST	OU.03			; no - try another record
	MOVE	TA,CUROTF		; get OTFTAB pointer for file
	LDB	TB,OT.DEV		; get the device
	CAIL	TB,3			; printer?
	CAILE	TB,5			; console?
	  JRST	OU.09			; no - do regular I/O
	LDB	TC,OT.OVI		; [131] get overflow indicator
	JUMPE	TC,OU.08C		; [131] no fetched overflow if none
	SKIPN	.OA-167(TC)		; [176] is secondary indicator on?
	  JRST	OU.08C			; [176] no -
	PUSHJ	PP,SKIND		; [131] is overflow condition set
	  JRST	OU.08C			; no - don't check any further
	MOVE	TA,CURREC		; get OCHTAB pointer for record
	LDB	TB,OC.FOV		; any need to check for forced overflow?
	JUMPE	TB,OU.08C		; apparently not if we jumped
	TSWF	FOVTIM;			; are we already processing forced overflow?
	  JRST	OU.08C			; yes - don't do it again
	SETOM	DIDFET##		; say we did a fetch
	SWON	FOVTIM!OVONLY;		; set some flags
	MOVE	TA,CUROTF		; get back OTFTAB pointer
	LDB	TB,OT.BFP		; get pointer to file buffer
	LDB	TC,OT.BSZ		; get buffer size in words
	ADDI	TC,LPSBUF		; [131] get last location of temp store buffer
	HRLI	TB,LPSBUF		; get pointer to temp storage
	MOVEM	TB,BLTHLD		; save BLT word for later
	MOVSS	TB			; make it go in right direction
	BLT	TB,(TC)			; save the current buffer
	MOVE	TB,BLTHLD		; [131] set up to zap buffer
	HRL	TB,TB			; [131] get buff-start,,buff-start
	SETZM	(TB)			; [131] zap a token word
	ADDI	TB,1			; [131] get buff-start,,buff-start+1
	LDB	TC,OT.BSZ		; [131] get buffer size
	ADD	TC,BLTHLD		; [131] create pointer to last buff word
	BLT	TB,(TC)			; [131] zap that buffer
	SPUSH	<0,CURREC,CUROCH,AITCH,DEE,TEE,ECKS>;
	SETZM	AITCH			; save some stuff and then reset it
	SETZM	DEE			;
	SETZM	ECKS			;
	SETOM	TEE			; do total output first
	SWOFF	LONLY;			; [131] make sure flag is reset
	PUSHJ	PP,OU.00B		; go do the output
	SETZM	TEE			; reset tee
	SETOM	AITCH			; now do header output
	PUSHJ	PP,OU.00B		; 
	SETZM	AITCH			; turn off AITCH
	SETOM	DEE			; now do detail output
	PUSHJ	PP,OU.00B		; thusly
	SPOP	<ECKS,TEE,DEE,AITCH,CUROCH,CURREC,0>;
	SWOFF	FOVTIM!OVONLY;		; [173] reset the flags
	MOVE	TB,BLTHLD		; restore pointers and return buffer
	MOVE	TA,CUROTF		; get our OTFTAB pointer back
	LDB	TC,OT.BSZ		; get buffer size
	ADD	TC,BLTHLD		; [131] add to start of buffer area
	BLT	TB,(TC)			; and restore buffer
;OU.08C		Handle somewhat special output for Printer and Console
;
;
;

OU.08C:	MOVE	TA,CUROTF		; RECOVER POINTER
	LDB	TF,OT.CHN		; get psuedo-channel number
	IMULI	TF,CHNSIZ		; times channel size
	ADD	TF,CHNBAS		; indexed against the base address
	LDB	TE,OT.DEV		; GET DEVICE
	LDB	TD,OT.LPP		; GET LINES/PAGE
	LDB	TG,OT.OVI		; GET OVERFLOW INDICATOR
	MOVE	TA,CURREC		; GET POINTER TO RECORD
	LDB	TB,OC.SKB		; GET "SKIP BEFORE"
	SKIPE	TB			; DON'T DO ANYTHING IF ZERO
	  PUSHJ	PP,SKOUT		; OTHERWISE SKIP TO MY LOU
	LDB	TB,OC.SPB		; GET "SPACE BEFORE"
	SKIPE	TB			; IGNORE IF ZERO
	  PUSHJ	PP,SPOUT		; PUT OUT SOME DC3's
	MOVE	TA,CUROTF		; GET BACK FILE POINTER
	PUSH	PP,TF			; save current contents of CHNTAB pointer
	SETZ	TF,			; MAKE IT BUILD A CHNTAB POINTER
	MOVEI	TB,3			; [171] set up for write with no advancing
	PUSHJ	PP,XFIL			; GO DO THE WRITE
	POP	PP,TF			; restore CHNTAB pointer
	MOVE	TA,CURREC		; GET BACK THE RECORD POINTER
	LDB	TB,OC.SKA		; GET "SKIP AFTER" ENTRY
	SKIPE	TB			; IGNORE IF ZERO	
	  PUSHJ	PP,SKOUT		; SKIP TO IT
	LDB	TB,OC.SPA		; GET "SPACE AFTER"
	SKIPE	TB			; DON'T DO ANYTHING WITH ZERO
	  PUSHJ	PP,SPOUT		; GO SPOUT OFF
	MOVE	TA,CUROTF		; GET FILE POINTER
	LDB	TB,OT.OVL		; GET OVERFLOW LINE
	TSWT	FOVTIM;			; ignore if this is fetched output
	CAML	TB,LIN(TF)		; COMPARE TO CURRENT LINE
	  JRST	OU.03			; ALL OK
	LDB	TC,OT.OVI		; [004] OVERFLOW - GET INDICATOR
	JUMPE	TC,OU.03		; [004] IGNORE IF NO INDICATOR
	PUSHJ	PP,SINDT##		; [004] TURN ON INDICATOR (NOW!!)
	SETOM	OVTIM			; [004] FLAG AS OVERFLOW TIME
	JRST	OU.03			; [004] AND EXIT
;SPOUT		Routine to space n lines on LPT or TTY
;
;	Enter with number of lines to space in TB. The actual spacing
;	is done in WAD2 in CBLIO.
;
;
;

SPOUT:	ADDM	TB,LIN(TF)		; update the line counter
	PUSH	PP,TF			; save CHNTAB pointer
	PUSH	PP,TA			; save a pointer
	MOVE	TA,CUROTF		; and get OTFTAB pointer
	LDB	AC16,OT.FTB		; get FTBTAB pointer
	MOVE	AC4,TB			; get count into proper AC
	PUSHJ	PP,SETCN.##		; set up the UUO table
	MOVE	FLG,F.WFLG(AC16)	; get those flags
	MOVE	AC5,D.OBB(AC16)		; get output pointer
	MOVEI	AC11,$DC3		; get a DC3
	MOVE	AC14,D.DC(AC16)		; get device characteristics
	TLNN	AC14,(DV.LPT)		; is it real LPT:?
	  MOVEI	AC11,$LF		; no - use line-feed
	PUSHJ	PP,WAD2##+1		; and go space
	POP	PP,TA			; restore pointer
	POP	PP,TF			; restore CHNTAB pointer
	POPJ	PP,			; and exit
;SKOUT		Routine to space to line n on TTY or LPT
;
;Enter with line to space to in TB
;
;
;

SKOUT:	CAMLE	TB,LIN(TF)		; are we past it?
	  JRST	SKOUT1			; no -
	MOVEI	TC,1			; yes - do a form feed
	MOVEM	TC,LIN(TF)		; reset line counter
	PUSH	PP,TF			; save CHNTAB pointer
	PUSH	PP,TB			; save count
	PUSH	PP,TA			; save pointer
	MOVE	TA,CUROTF		; get OTFTAB pointer
	LDB	AC16,OT.FTB		; get pointer into FTBTAB
	PUSHJ	PP,SETCN.		; set up the UUO table
	MOVE	FLG,F.WFLG(AC16)	; get a word full of flags
	MOVEI	AC4,1			; just one form-feed
	MOVE	AC5,D.OBB(AC16)		; get output pointer
	MOVEI	AC11,$FF		; get that form feed
	PUSHJ	PP,WAD2+1		; [121] go output it
	POP	PP,TA			; restore pointer
	POP	PP,TB			; restore count
	POP	PP,TF			; restore CHNTAB pointer

SKOUT1:	SUB	TB,LIN(TF)		; get number to skip
	SKIPE	TB			; exit if we're already there
	  PUSHJ	PP,SPOUT		; output appropriate number of spaces
	POPJ	PP,			; exit
;OU.09		Perform output for all standard devices
;
;
;

OU.09:	MOVE	TA,CUROTF		; GET FILE POINTER
	LDB	TF,OT.CHN		; GET CHANNEL
	IMULI	TF,CHNSIZ		; MAKE INTO A POINTER
	ADD	TF,CHNBAS		; INDEX AGAINST BASE
	LDB	TB,OT.TYP		; GET FILE TYPE
	CAIN	TB,2			; UPDATE?
	  JRST	OU.11			; YES -

OU.09B:	LDB	TB,OT.DEV		; get device
	CAIG	TB,1			; [074] MFCU?
	  JRST	OU.10A			; yes -
	LDB	TB,OT.ORG		; NO - GET ORGANIZATION
	CAIN	TB,2			; INDEXED?
	  JRST	OU.16			; YES -
	AOS	TB,KEY(TF)		; NO - BUMP KEY
	LDB	TC,OT.FTB		; get pointer to FTBTAB
	HRRZ	TC,F.RACK(TC)		; get pointer to actual key
	SKIPE	TC			; is there one?
	  MOVEM	TB,(TC)			; yes - set it up for CBLIO

OU.10:	MOVEI	TB,1			; SET UP FOR WRITE
	PUSHJ	PP,XFIL			; GO DO IT
;[164]	SETOM	RWF(TF)			; SAY WE ARE GOING TO MESS WITH IT
	JRST	OU.03			; exit

OU.11:	LDB	TB,OT.ORG		; GET ORGANIZATION
	CAIE	TB,2			; INDEXED?
	  JRST	OU.15			; NO -
	MOVE	TA,CURREC		; YES - GET RECORD POINTER
	LDB	TB,OC.ADD		; ADD?
	MOVE	TA,CUROTF		; [145] get OTFtab pointer
	JUMPN	TB,OU.16		; YES -
	LDB	TB,OT.FTB		; get FTBTAB link
	MOVE	TB,F.WBSK(TB)		; get byte pointer to symbolic key
	MOVE	TC,[POINT 6,UPD(TF)]	; get pointer to update key
	LDB	TD,OT.KYL		; get key length

OU.12:	ILDB	CH,TC			; get character from update key
	IDPB	CH,TB			; stash in symbolic key
	SOJG	TD,OU.12		; loop until entire key moved
	JRST	OU.17			; then go do rewrite
;OU.09 (cont'd)
;
;OU.15		Handle Update key for record relative key
;
;

OU.15:	MOVE	TB,UPD(TF)		; GET UPDATE KEY
	MOVEM	TB,KEY(TF)		; STASH AS KEY
	LDB	TC,OT.FTB		; get FTBTAB pointer
	HRRZ	TC,F.RACK(TC)		; get actual key pointer
	SKIPE	TC			; is there an actual key?
	  MOVEM	TB,(TC)			; yes - set it
	MOVE	TA,CUROTF		; RESTORE FILE POINTER
	JRST	OU.10			; GO SET UP


;OU.16		Handle Indexed I/O
;
;

OU.16:	TSWF	FREAD;			; chained i/o?
	  JRST	OU.18			; yes - do a write
	LDB	TB,OT.FTB		; else get FTBTAB pointer
	MOVE	TC,F.WBSK(TB)		; and get pointer to symbolic key
	MOVE	TB,F.WBRK(TB)		; and pointer to record key
	LDB	TD,OT.KYL		; and key length

OU.16A:	ILDB	CH,TB			; get character from record key
	IDPB	CH,TC			; and move it to symbolic key
	SOJG	TD,OU.16A		; and loop until done
	MOVE	TA,CURREC		; get current OCHTAB pointer
	LDB	TB,OC.ADD		; and get ADD record flag
	MOVE	TA,CUROTF		; get OTFTAB pointer
	LDB	TC,OT.TYP		; get the file type
	CAIE	TC,2			; update?
	  JRST	OU.18			; no - use WRITE
	JUMPN	TB,OU.18		; yes - use write if ADD

OU.17:	MOVEI	TB,2			; else use rewrite
	PUSHJ	PP,XFIL			; output the stuff
	JRST	OU.03			; and loop

OU.18:	MOVEI	TB,1			; use write
	PUSHJ	PP,XFIL			; output it
	JRST	OU.03			; and loop
;OU.10A		Handle MFCU
;
;
;

OU.10A:	MOVE	TA,CURREC		; get record pointer
	LDB	TC,OC.STS##		; get stacker select
	JUMPN	TC,.+6			; we have priotrity over all else
	SKIPE	TC,MFINST##		; get input stacker select
	  JRST	.+4			; use that as next priority
	MOVEI	TC,1			; else default to 1 for hopper 1
	SKIPE	MFLAST##		; was it hopper 1?
	  MOVEI	TC,4			; no - use 4 for hopper 2
	MOVEM	TC,MFOREC##		; save stacker select
	MOVE	TB,BUF(TF)		; get buffer location
	LDB	TD,OT.BSZ		; get buffer size	
	MOVE	TA,MFOTF-1(TC)		; get OTFTAB pointer for selected stacker
	LDB	TF,OT.CHN		; get psuedo-channel
	IMULI	TF,CHNSIZ		; times size of entry
	ADD	TF,CHNBAS		; plus base address
	HRLZS	TB			; get start in LH
	HRR	TB,BUF(TF)		; get to in RH
	MOVE	TC,BUF(TF)		; get it again
	ADDI	TC,1(TD)		; get last location
	BLT	TB,(TC)			; and transfer buffer
	JRST	OU.03			; loop


;Define Miscellaneous Tables for OUTPT routines
;
;
;

ORTAB:	AITCH				; HEADER
	DEE				; DETAIL
	TEE				; TOTAL
	ECKS				; EXCEPTION
;NOW THAT WE HAVE ALL THE HARD CORE I/O ROUTINES DONE, AT THE
;EXPENSE OF MANY LATE NIGHTS, IT COMES TIME TO DO THE INITIALIZATION.
;THIS SHOULD BE A RATHER TRIVIAL TASK, ALL IT MUST DO IS SET UP
;THE PDL, SET UP UUO DISPATCH, THE TRAPS, AND THE OPEN ALL THE
;FILES, PAYING CAREFUL ATTENTION TO WHAT KIND OF FILE IT IS. AFTER
;ALL THAT IS DONE, WE CAN LEAP OFF INTO THE REAL MAINLINE CODE.
;
;
;	Then Sir Beaumains...rode all that he might ride
;	through marshes and fields and great dales, that many 
;	times...he plunged over the head in deep mires, for
;	he knew not the way, but took the gainest way in that
;	woodness...And at the last him happened to come to
;	a fair green way.
;
;				Malory, Le Morte d'Arthur
;
;
SUBTTL	RESET routines

;RESET.		RESET ALL BEASTS, GREAT AND SMALL
;
;THIS IS THE FIRST THING THAT THE OBJECT PROGRAM CALLS
;

RESET.:	RESET				; TELL THE WORLD TO GO TO HELL
	MOVE	TA,(AC14)		; get address of address of files
	MOVEM	TA,%F.PTR##		; leave where the foolish CBLIO can find it
	HRRZ	TA,.JBFF		; TO - 1
	CAMG	TA,.JBREL		; AVOID AN ILLEGAL MEM REF
	SETZM	(TA)			; ZAP WORD
	HRL	TA,TA			; FROM,,TO-1
	ADDI	TA,1			; FROM,,TO
	HRRZ	TB,.JBREL		; UNTIL
	CAIL	TB,(TA)			; AVOID ERROR IF .JBFF = .JBREL
	BLT	TA,(TB)			; ZERO FREE CORE
	MOVEI	TA,[OUTSTR [ASCIZ /RPGII programs may only be started thru use of "GET and ST" or "RUN" monitor commands
/]
		EXIT]			; TELL THE TURKEY WHERE TO GO
	HRRM	TA,.JBSA		; WHERE TO PUT MESSAGE
	HRRM	TA,.JBREN		; STORE AS REENTER ALSO
	MOVE	PP,[PUSHJ PP,UUO.]	; GET DISPATCH TO UUO HANDLER
	MOVEM	PP,.JB41		; STORE
IFN STATS,<
	MSTIME	TA,			; GET TIME OF DAY
	MOVEM	TA,%TIME0##		; STASH
	MOVEM	TA,%TIME1##
	SETZ	TA,			; GET JOB
	RUNTIM	TA,			; GET RUNTIME
	MOVEM	TA,%RTIM0##
	MOVEM	TA,%RTIM1##
	SETZM	%TIMEP##
	SETZM	%RTIMP##
	SETZM	%TIMER##
	SETZM	%RTIMR##
	>
	MOVE	PP,[XWD PFRST.,IFRST.]	; get address of i/o UUO's
	TLNE	PP,777777		; don't BLT if lowseg was loaded
	BLT	PP,ILAST.		; otherwise BLT away
	HRRZ	TA,1(AC14)		; get address of FILES.
	SKIPN	TA,%PUSHL(TA)		; do we have a special PDL size?
	  MOVEI	TA,200			; no - default to 200
	MOVNI	PP,(TA)			; make it negative
	HRL	PP,.JBFF		; STICK PDL IN FREE CORE
	MOVSS	PP			; get those halves straightened out
	MOVEI	TB,1(TA)		; get pdlsize+1
	ADDB	TB,.JBFF		; reset .JBFF to reflect PDL's presence
	IORI	TB,1777			; round up to nearest K
	CAMG	TB,.JBREL		; IS ENOUGH ROOM?
	  JRST	RESET1			; YES -
	CORE	TB,			; NO - EXPAND THE WORLD
	  JRST	GETCO1			; COULDN'T DO IT
;RESET.	(cont'd)
;
;
;

RESET1:	MOVE	TB,.JBFF		; GET NEW .JBFF
	MOVEM	TB,CHNBAS		; STORE AS BASE OF CHNTAB
	MOVEI	TB,CHNSIZ*20+1		; GET SIZE OF CHNTAB
	ADDB	TB,.JBFF		; UPDATE .JBFF
	IORI	TB,1777			; ROUND
	CAMG	TB,.JBREL		; ENUFF ROOM?
	  JRST	RESET2			; YES -
	CORE	TB,			; NO - EXPAND LOSEG
	  JRST	GETCO2			; GOTTA RAISE CORMAX FOLKS


RESET2:	MOVEI	TB,TRAP.		; GET TRAP HANDLER ADDRESS
	MOVEM	TB,.JBAPR		; STASH
	MOVEI	TB,230000		; GET FLAGS WE'RE INTERESTED IN
	APRENB	TB,			; ENABLE TRAPS
	AOS	14			; BUMP OUR RETURN ADDR
	HRL	TB,(14)			; ADDR OF "MAIN" + 1
	HRRI	TB,OTFBAS##		; PUT IT IN FIXED
	HRRZI	TC,OTFBAS		;
	BLT	TB,FIXNUM-1(TC)		; WHAT BLITS!
	AOS	14			; GOTTA BUMP IT ONE MORE TIME
	PUSH	PP,14			; THEN STORE AS RETURN ADDRESS

RESET3:	PUSHJ	PP,OUTBF1##		; setup TTY byte pointer and byte count
	PUSHJ	PP,RSTAB.##		; assign the buffer area's
	PUSHJ	PP,RSTOP.		; open those files
	PUSHJ	PP,RSTARR		; read any array/table files
	MOVE	TB,.STLST##		; get stacker list
	JUMPE	TB,A.00			; leave if zero
	MOVEM	TB,MFOTF##		; save as loc of stacker 1
	ADDI	TB,OTFSIZ		; increment
	MOVEM	TB,MFOTF+1		; save as stacker 2
	ADDI	TB,OTFSIZ		; increment again
	MOVEM	TB,MFOTF+2		; save as stacker 3
	ADDI	TB,OTFSIZ		; and again
	MOVEM	TB,MFOTF+3		; save as stacker 4
	JRST	A.00			; and off we go
;RSTOP.		Routine to open all files
;
;
;

RSTOP.:	MOVE	TA,OTFBAS		; get start of OTFBAS
	MOVEM	TA,CUROTF		; stash as current pointer
	SETOM	CURCHN##		; initialize psuedo-channel number

RSTOP1:	LDB	AC16,OT.FTB##		; get corresponding FTBTAB address
	HRLI	AC16,001100		; get those flags
	AOS	TB,CURCHN		; get the next psuedo-channel
	DPB	TB,OT.CHN		; stash
	IMULI	TB,CHNSIZ		; times size of entry
	ADD	TB,CHNBAS		; plus base address
	LDB	TC,OT.BFP		; get pointer to buffer
	MOVEM	TC,BUF(TB)		; store in CHNTAB for others
	LDB	TB,OT.TYP		; get type of file
	JUMPE	TB,.+3			; input?
	CAIE	TB,2			; update?
	CAIN	TB,3			; combined?
	  TLO	AC16,(1B10)		; flag as input
	CAIE	TB,1			; output?
	CAIN	TB,2			; update?
	  TLO	AC16,(1B9)		; flag as output
	PUSHJ	PP,C.OPEN##		; go do the actual open in CBLIO
	MOVE	TA,CUROTF		; get that OTFTAB pointer
	LDB	TC,OT.LAS		; get last entry flag
	JUMPN	TC,RET.1##		; return if we're all done
	ADDI	TA,OTFSIZ		; else make pointer to next entry
	MOVEM	TA,CUROTF		; save pointer
	JRST	RSTOP1			; and loop
;RSTARR		Routine to read any table/array files that may exist
;
;
;

RSTARR:	MOVE	TA,ARRBAS##		; get start of ARRTAB
	JUMPE	TA,RET.1		; exit if none

RSTAR4:	MOVEM	TA,CURARR##		; save the pointer
	LDB	TB,AR.LDM##		; get load/dump flag
	JUMPN	TB,RSTAR3		; if dump ignore it
	SWOFF	FALT!FUALT;		; turn off some flags
	LDB	TB,AR.ALT##		; get alternating table flag
	JUMPE	TB,RSTAR6		; jump if not
	MOVEM	TB,CURARP##		; save pointer
	SWON	FALT;			; and turn on flag

RSTAR6:	LDB	TA,AR.FIL##		; get OTFTAB pointer
	MOVEM	TA,CUROTF		; save for others
	LDB	TF,OT.CHN		; get psuedo channel
	IMULI	TF,CHNSIZ		; make into standard pointer
	ADD	TF,CHNBAS		; add in the base
	MOVEM	TF,CURCHN		; save a current pointer
	PUSHJ	PP,INPT			; read in a record from the file
	  JRST	RSTAR7			; error
	SKIPE	EOF(TF)			; at end-of-file ?
	  JRST	RSTAR7			; yes -
	MOVE	TA,CUROTF		; get back OTFTAB pointer
	LDB	IPTR,OT.BFP		; get pointer into buffer
	HRLI	IPTR,440600		; make into byte pointer
	MOVE	TA,CURARR		; get ARRTAB pointer
	LDB	OPTR,AR.PNT##		; get pointer to table
	LDB	CNTA,AR.OCC##		; get size of table
	TSWF	FALT;			; alternating tables?
	  IMULI	CNTA,2			; yes - double size count

RSTAR2:	LDB	CNTR,AR.EPR##		; get entries/record
	TSWF	FALT;			; [105] alternating tables?
	  IMULI	CNTR,2			; [105] yes - double count

RSTAR5:	TSWT	FALT;			; alternating tables?
	  JRST	RSTAR0			; no -
	TSWC	FUALT;			; complement use flag
	EXCH	OPTR,CURARP		; use the other table

RSTAR0:	LDB	CNT,AR.SIZ##		; get size of entry
	TSWF	FUALT;			; using alternate table?
	  LDB	CNT,AR.ASZ##		; yes - use alternate size
;RSTARR (cont'd)
;
;
;

RSTAR1:	ILDB	TB,IPTR			; get a character from the file
	IDPB	TB,OPTR			; stash it
	SOJG	CNT,RSTAR1		; loop if any left in field
	SOJLE	CNTA,RSTAR3		; jump if no more table entries left
	SOJG	CNTR,RSTAR5		; loop if any entries left in record
	SPUSH	<OPTR,CNTA>		; else save some stuff on the stack
	MOVE	TA,CUROTF		; get OTFTAB pointer
	MOVE	TF,CURCHN		; get back CHNTAB pointer
	PUSHJ	PP,INPT			; read a record
	  JRST	RSTAR7			; error
	SKIPE	EOF(TF)			; at end-of-file?
	  JRST	RSTAR7			; yes - bad
	MOVE	TA,CUROTF		; get OTFTAB pointer
	LDB	IPTR,OT.BFP		; get pointer to buffer
	HRLI	IPTR,440600		; make into byte pointer
	MOVE	TA,CURARR		; get ARRTAB pointer back
	SPOP	<CNTA,OPTR>		; restore some stuff
	JRST	RSTAR2			; and loop

RSTAR3:	MOVE	TA,CUROTF		; get the current OTFTAB pointer
	LDB	TB,OT.DEV		; get the file device
	CAIE	TB,2			; a CDR: ?
	  JRST	RSTAR9			; no - no special treatment
	MOVE	TA,CURARR		; get current pointer
	LDB	TB,AR.LAS		; get last entry flag
	JUMPN	TB,RSTR10		; if is ignore whats next
	ADDI	TA,SZ.ARR		; get next entry
	LDB	TB,AR.FIL		; get OTFTAB pointer
	CAMN	TB,CUROTF		; same as old one?
	  JRST	RSTAR9			; yes - don't reset anything

RSTR10:	MOVE	TA,CUROTF		; get OTFTAB pointer back
	LDB	TC,OT.FTB		; get FTBTAB pointer
	LDB	TD,OT.CHN		; get CHNTAB number
	LDB	TE,OT.BFP		; [117] get buffer pointer

RSTAR8:	LDB	TB,OT.LAS		; get last entry flag
	JUMPN	TB,RSTAR9		; exit when done
	ADDI	TA,OTFSIZ		; else get next entry pointer
	LDB	TB,OT.DEV		; get device
	CAIE	TB,2			; CDR: ?
	  JRST	RSTAR8			; no - try another file
	DPB	TD,OT.CHN		; yes - replace old CHNTAB number with new
	DPB	TE,OT.BFP##		; [117] replace buffer pointer
	MOVE	TE,F.WFLG(TC)		; [117] get flags and buffer pointer
	MOVE	TD,TE			; [117] move to ac we can play with
	TLZ	TD,OPNIN+OPNOUT		; [117] clear open flags
	MOVEM	TD,F.WFLG(TC)		; [117] replace
	SUBI	TC,-D.LBN		; get pointer to start of device table
	HRLZS	TC			; get into proper half for a BLT
	LDB	TD,OT.FTB		; get start of new FTBTAB
	MOVEM	TE,F.WFLG(TD)		; [117] store flags and buffer address
	HRRI	TC,D.LBN(TD)		; get start of new device table
	BLT	TC,-1(TD)		; blit away the device table
;RSTARR (cont'd)
;
;
;

RSTAR9:	MOVE	TA,CURARR		; get ARRTAB pointer back
	LDB	TB,AR.LAS##		; get last entry flag
	JUMPN	TB,RET.1		; if it is last then exit
	ADDI	TA,SZ.ARR##		; else increase pointer
	JRST	RSTAR4			; and loop

RSTAR7:	PUSHJ	PP,%%H.16		; no table data found
	MOVE	TA,CURARR		; get pointer
	JRST	RSTAR3			; and try next table
SUBTTL	Common Routines

;COMMON ROUTINES
;
;THESE ROUTINES ARE USED ALL OVER THE PLACE, AND ARE PUT HERE FOR
;LACK OF ANYPLACE BETTER.
;
;	Eh? Who let that commoner in here?
;
;			Roy Thomas, The Blood of the Dragon
;
;
;HANDLE TRAPS

TRAP.:	MOVE	TA,.JBCNI		; GET STATE OF APR
	TRNE	TA,20000		; MEM PROT VIOLAION?
	OUTSTR	[ASCIZ /Memory protection violation /]
	TRNE	TA,10000		; NXM?
	OUTSTR	[ASCIZ /Non-existant memory /]
	TRNE	TA,200000		; PDL OV?
	OUTSTR	[ASCIZ /Pushdown overflow /]
	OUTSTR	[ASCIZ /at user address /]
	HRLO	TD,.JBTPC		; GET OFFENDING LOCATION
	JSP	JAC,PPOUT2		; print it
	JRST	DEATH			; GO DIE

PPOUT2:	MOVEI	TC,6			; half a sixbit '0'
	LSHC	TC,3			; get the other half
	OUTCHR	TC			; print the digit
	TRNE	TD,-1			; all done?
	  JRST	PPOUT2			; no - loop
	OUTSTR	[ASCIZ /
/]
	JRST	(JAC)			; return
;PRINT OUT MEMORY LOCATION IN LH OF TD, RH = -1

PPOUT:	MOVEI	TC,6			; HALF ASCII ZERO - 60
	LSHC	TC,3			; APPEND OCTAL NUMBER
	OUTCHR	TC			; OUTPUT IT
	TRNE	TD,-1			; SIX NUMBERS?
	JRST	PPOUT			; NO - LOOP
	OUTSTR	[ASCIZ /
/]
	POPJ	PP,			; YES - EXIT


;TYPE ERROR FOR CORE EXPANSION FAILURES

GETCO1:	OUTSTR	[ASCIZ /?Insuffcient core for PDL expansion
/]
	JRST	DEATH

GETCO2:	OUTSTR	[ASCIZ /?Insufficient core for CHNTAB expansion
/]
	JRST	DEATH
;PUT OUT SIXBIT WORD ONTO TTY

SIXOUT:	MOVE	TE,[POINT 6,TA]		; GET POINTER
SIXO1:	ILDB	TD,TE			; GET A CHAR
	JUMPE	TD,SIXEND		; IF ZERO, ALL DONE
	ADDI	TD,40			; INTO THE REALM OF ASCII
	OUTCHR	TD			; TYPE IT
	TLNE	TE,770000		; ALL DONE?
	JRST	SIXO1			; NO - LOOP
SIXEND:	POPJ	PP,			; YES -
;
;
;
;DEATH.
;
;
;

DEATH:	OUTSTR	[ASCIZ /?Fatal error in RPGLIB
Run aborted.
/]
	EXIT
;CKIND		ROUTINE TO CHECK INDICATOR CONDITIONS
;		THIS PARTICULAR VARIATION ON A FAMILIAR THEME ALSO
;		CHECKS FOR INDICATOR TYPES, SETTING APPROPRIATE
;		FLAGS.
;
;

CKIND:
IFN STATS,<
	SETZ	7,
	RUNTIM	7,
	MOVEM	7,%RTIM2##
	AOS	%INDC2##
	>
CKIND0:	MOVEM	TA,.CKSPC##		; [147] save pointer to space/skip entries
	ADDI	TA,1			; [147] increment pointer
	MOVEM	TA,.SVI##		; [176] save pointer
	LDB	TF,ID.IND		; GET INDICATOR
	MOVE	TE,(TA)			; SAVE
	JUMPE	TF,CKIND3		; zero is always on
	CAIL	TF,167			; OV?
	CAILE	TF,176			;
	  JRST	.+3			; NO -
	SWON	OVFLG;			; YES - SET FLAG
	JRST	CKIND1			; NO NEED TO CHECK FURTHER
	CAIL	TF,155			; CONTROL LEVEL?
	CAILE	TF,166			; INCLUDING LR
	  JRST	.+3			; NO -
	SWON	LFLG;			; YES - SET FLAG
	JRST	CKIND1			; CONTINUE
	CAIN	TF,211			; [176] L0?
	  SWON	LFLG;			; YES -

CKIND1:	JSP	JAC,SKIND2##		; IS INDICATOR ON?
	  JRST	CKIND2			; NO - GO CHECK FOR NOT
	TLNE	TE,(1B1)		; IS NOT ENTRY SET?
	  JRST	CKIND4			; YES - NO GO

CKIND3:	TRNE	TE,1B22			; IS ID.END SET?
	  JRST	CKIND6			; YES -
	MOVE	TE,1(TA)		; [071] get next word
	JUMPL	TE,CKIND6		; JUMP IF ID.OR (B0) IS SET
	AOJA	TA,CKIND0+2		; [166] ELSE INCREMENT AND LOOP

CKIND2:	TLNE	TE,(1B1)		; NOT ENTRY SET?
	  JRST	CKIND3			; YES - OK

CKIND4:	SWOFF	OVFLG!LFLG;		; RESET SOME FLAGS
	TRNE	TE,1B22			; END FLAG?
	  JRST	CKIND7			; YES -
	ADDI	TA,1			; GET NEXT ENTRY
	MOVE	TE,(TA)			; GET THE CONTENTS
	JUMPGE	TE,CKIND4+1		; LOOP IF ID.OR (B0) NOT SET
	JRST	CKIND0			; IF SET TRY AGAIN
;CKIND (cont'd)
;
;
;

CKIND6:	MOVE	TB,@.CKSPC		; [147] get space/skip entries
	MOVE	TA,CURREC		; [147] get current OCHTAB pointer
	LDB	TC,.CKSPB		; [147] get space before
	DPB	TC,OC.SPB		; [147] store
	LDB	TC,.CKSKB		; [147] get skip before
	DPB	TC,OC.SKB		; [147] store
	LDB	TC,.CKSPA		; [147] get space after
	DPB	TC,OC.SPA		; [147] store
	LDB	TC,.CKSKA		; [147] get skip after
	DPB	TC,OC.SKA		; [147] store
	MOVE	TC,.SVI			; [176] get saved pointer
	MOVEM	TC,.SVIND		; [176] and put where others can get it
	AOS	(PP)			; TAKE SKIP RETURN

CKIND7:
IFN STATS,<
	SETZ	7,
	RUNTIM	7,
	SUB	7,%RTIM2
	ADDM	7,%RTIMC##
	>
	POPJ	PP,			; EXIT

.CKSPB:	POINT	2,TB,19			; [147] pointer to space before
.CKSKB:	POINT	7,TB,26			; [147] pointer to skip before
.CKSPA:	POINT	2,TB,28			; [147] pointer to space after
.CKSKA:	POINT	7,TB,35			; [147] pointer to skip after
SUBTTL	Error and Halt Routines

;HLTOPT		Halt procedure routines
;
;
;

HLTOPT:	SUBI	AC16,1			; decrement the calling address
	MOVE	TB,AC16			; get into AC we can play with
	SUBI	TB,%%H.H1		; convert to orgin zero
	ASH	TB,-1			; divide by two
	OUTSTR	[ASCIZ /%Entered halt procedure /]
	MOVE	TC,%ERTAB(TB)		; get the error message
	OUTSTR	(TC)			; output it
	OUTSTR	[ASCIZ /
/]
	MOVE	TC,1(AC16)		; get flags
	TLNN	TC,(%FILE)		; must we output file name?
	  JRST	HLT.01			; no -
	OUTSTR	[ASCIZ /File is /]	; yes -
	MOVE	TA,CUROTF		; get OTFTAB pointer
	LDB	TC,OT.FTB		; then get FTBTAB pointer
	MOVEI	TB,^D30			; file nameis thirty characters long
	HRLI	TC,440600		; convert to byte pointer

HLT.06:	ILDB	CH,TC			; get a character
	JUMPE	CH,HLT.07		; space is terminator
	ADDI	CH,40			; convert to ASCII
	OUTCHR	CH			; output it
	SOJG	TB,HLT.06		; loop if necessary

HLT.07:	OUTSTR	[ASCIZ / [/]		; formatting
	LDB	TC,OT.FTB		; get FTBTAB pointer back
	MOVE	TC,F.WVID(TC)		; get pointer to value-of-id
	MOVEI	TB,^D9			; filename is nine characters

HLT.08:	ILDB	CH,TC			; get a character
	ADDI	CH,40			; convert to ASCII
	OUTCHR	CH			; output it
	SOJG	TB,HLT.08		; loop
	OUTSTR	[ASCIZ /]
/]

HLT.01:	CLRBFI				; just to be safe
	OUTSTR	[ASCIZ /
Please select a halt option: /]
	MOVE	TB,[POINT 6,TC]		; get pointer to buffer
	SETZ	TC,			; zap the buffer

HLT.02:	INCHWL	CH			; get a character
	CAIN	CH,.CHCRT		; cariage return?
	  JRST	HLT.03			; yes -
	CAIN	CH,.CHLFD		; line feed?
	  JRST	HLT.04			; yes -
	SUBI	CH,40			; convert to sixbit
	CAILE	CH,77			; upper case?
	  SUBI	CH,40			; no - convert some more
	IDPB	CH,TB			; stash the character
	TLNE	TB,770000		; all out of room?
	  JRST	HLT.02			; no - loop

HLT.03:	INCHWL	CH			; get another character
	CAIE	CH,.CHLFD		; line feed?
	  JRST	HLT.03			; No - loop until we do get one

HLT.04:	JUMPE	TC,HLTDEF		; carriage return of spaces = default
	MOVEI	TB,OPCNT		; get count of table entries
	CAME	TC,OPTAB1(TB)		; is this it?
	  SOJGE	TB,.-1			; no - loop
	JRST	@DISTAB(TB)		; yes - dispatch

HLT.05:	OUTSTR	LONGMS			; invalid response -
	JRST	HLT.01			; try again

LONGMS:	ASCIZ /?Please use one of the following options (Enter single digit or alpha command):

0	Continue: Control is returned to the program, and processing
		  continues.
1	Bypass: The remainder of the program cycle is bypassed, and the 
		next record is read.
2	Controlled Cancel: End-of-job operations (specified by an LR 
		indicator in your program) are done, tables are
		dumped, and files are closed.
3	Immediate Cancel: The job is cancelled without returning control
		to the RPG II program.
4	DDT: DDT is entered if it was loaded during compiler generation.
<CR>	Default: The default action for the partciular error is taken.

/
;HLTOPT (cont'd)
;
;
;

HLTCON:	MOVE	TC,1(AC16)		; get flags word
	TLNE	TC,(%CONT)		; continue allowed?
	  POPJ	PP,			; yes - well do so
	OUTSTR	[ASCIZ /?Continue is not allowed for this error
/]
	JRST	HLT.01			; one more time

HLTBY:	MOVE	TC,1(AC16)		; get the flags
	TLNE	TC,(%BYPAS)		; ok?
	  JRST	A.01##			; yes -
	OUTSTR	[ASCIZ /?Bypass is not allowed for this error
/]
	JRST	HLT.01			; oh well - nice try

HLTCCN:	MOVE	TC,1(AC16)		; get flags
	TLNE	TC,(%CCAN)		; ok?
	  JRST	H.01			; yes -
	OUTSTR	[ASCIZ /?Controlled cancel is not allowed for this error
/]
	JRST	HLT.01			; nope

HLTICN:	MOVE	TC,1(AC16)		; get flags
	TLNE	TC,(%ICAN)		; ok?
	  JRST	H.100			; yes -
	OUTSTR	[ASCIZ /?Immediate cancel is not allowed for this error
/]
	JRST	HLT.01			; no -

HLTDEF:	LDB	TB,[POINT 3,1(AC16),5]	; get default code
	JUMPE	TB,HLTDF1		; zero means invalid
	OUTSTR	@DEFTB2-1(TB)		; output message
	OUTSTR	[ASCIZ /
/]
	JRST	@DEFTAB-1(TB)		; off to default routine is there is one

HLTDF1:	OUTSTR	[ASCIZ /?No default is specified for this error
/]
	JRST	HLT.01			; make him work

DEFTB2:	[ASCIZ	/%Using Continue/]
	[ASCIZ	/%Using Bypass/]
	[ASCIZ	/%Using Controlled Cancel/]
	[ASCIZ	/%Using Immediate Cancel/]
;HLTOPT	(cont'd)
;
;
;

HLTDDT:	HRRZ	TB,.JBDDT		; is DDT loaded?
	JUMPN	TB,(TB)			; if so, go to it
	OUTSTR	[ASCIZ /?DDT has not been loaded
/]
	JRST	HLT.01			; else tell turkey and exit
;HLTOPT (cont'd)		Define tables and constants for HLTOPT
;
;
;

DEFTAB:	EXP	HLTCON
	EXP	HLTBY
	EXP	HLTCCN
	EXP	HLTICN

;Define severity codes

%S1==1B2
%S2==2B2
%S3==3B2
%S4==4B2
%S5==5B2
%S6==6B2
%S7==7B2

;Define default codes

%D0==1B5
%D1==2B5
%D2==3B5
%D3==4B5

;Define option codes

%CONT==1B6
%BYPAS==1B7
%CCAN==1B8
%ICAN==1B9

;Define Misc options

%FILE==1B10

;Format of a dispatch table flag word is as follows:
;
;	Bits 0-2	Severity of error
;	Bits 3-5	Default action
;	Bits 6-9	Allowable actions
;	Bit 10		Output File-name
;	Bits 11-35	Unused
;
;HLTOPT (cont'd)		Define dispatch table
;
;
;

%%H.H1::JSP	AC16,HLTOPT
	%CONT+%CCAN+%ICAN+%S4
%%H.H2::JSP	AC16,HLTOPT
	%CONT+%CCAN+%ICAN+%S4
%%H.H3::JSP	AC16,HLTOPT
	%CONT+%CCAN+%ICAN+%S4
%%H.H4::JSP	AC16,HLTOPT
	%CONT+%CCAN+%ICAN+%S4
%%H.H5::JSP	AC16,HLTOPT
	%CONT+%CCAN+%ICAN+%S4
%%H.H6::JSP	AC16,HLTOPT
	%CONT+%CCAN+%ICAN+%S4
%%H.H7::JSP	AC16,HLTOPT
	%CONT+%CCAN+%ICAN+%S4
%%H.H8::JSP	AC16,HLTOPT
	%CONT+%CCAN+%ICAN+%S4
%%H.H9::JSP	AC16,HLTOPT
	%CONT+%CCAN+%ICAN+%S4
%%H.H0::JSP	AC16,HLTOPT
	%CONT+%CCAN+%ICAN+%S4
%%H.11::JSP	AC16,HLTOPT
	%CONT+%CCAN+%ICAN+%S4+%D2
%%H.12::JSP	AC16,HLTOPT
	%CONT+%CCAN+%ICAN+%S4+%D2
%%H.13::JSP	AC16,HLTOPT
	%CONT+%CCAN+%ICAN+%S4+%D2
%%H.14::JSP	AC16,HLTOPT
	%CONT+%CCAN+%ICAN+%S4+%D2
%%H.15::JSP	AC16,HLTOPT
	%CCAN+%ICAN+%S4+%D2
%%H.16::JSP	AC16,HLTOPT
	%CONT+%CCAN+%ICAN+%S4+%D2
%%H.17::JSP	AC16,HLTOPT
	%CONT+%CCAN+%ICAN+%S4+%D2
%%H.18::JSP	AC16,HLTOPT
	%ICAN+%S2+%D3
%%H.19::JSP	AC16,HLTOPT
	%CONT+%ICAN+%S2+%D0
%%H.10::JSP	AC16,HLTOPT
	%ICAN+%S2+%D3
%%H.1A::JSP	AC16,HLTOPT
	%ICAN+%S2+%D3
%%H.1C::JSP	AC16,HLTOPT
	%CCAN+%ICAN+%S4+%D2
%%H.1E::JSP	AC16,HLTOPT
	%CONT+%CCAN+%ICAN+%S4+%D2+%FILE
%%H.1F::JSP	AC16,HLTOPT
	%CCAN+%ICAN+%S4+%D2+%FILE
%%H.1H::JSP	AC16,HLTOPT
	%CONT+%CCAN+%ICAN+%S4+%D2+%FILE
%%H.1J::JSP	AC16,HLTOPT
	%CONT+%CCAN+%ICAN+%S4+%D2+%FILE
%%H.1L::JSP	AC16,HLTOPT
	%CONT+%CCAN+%ICAN+%S4+%D2+%FILE
%%H.1P::JSP	AC16,HLTOPT
	%CONT+%BYPAS+%S1
%%H.1U::JSP	AC16,HLTOPT
	%BYPAS+%CCAN+%ICAN+%S4+%D2+%FILE
%%H.1Y::JSP	AC16,HLTOPT
	%CONT+%BYPAS+%CCAN+%ICAN+%S4+%D0
%%H.1::	JSP	AC16,HLTOPT
	%CONT+%ICAN+%S4
%%H.J1::JSP	AC16,HLTOPT
	%BYPAS+%CCAN+%ICAN+%S4+%D2+%FILE
%%H.L1::JSP	AC16,HLTOPT
	%BYPAS+%CCAN+%ICAN+%S4+%D2+%FILE
%%H.U1::JSP	AC16,HLTOPT
	%BYPAS+%CCAN+%ICAN+%S4+%D2+%FILE
%%H.J0::JSP	AC16,HLTOPT
	%CONT+%CCAN+%ICAN+%S4+%D2
%%H.U0::JSP	AC16,HLTOPT
	%ICAN+%S7+%D3


;Define Misc tables

OPTAB1:	SIXBIT	/0/
	SIXBIT	/1/
	SIXBIT	/2/
	SIXBIT	/3/
	SIXBIT	/4/
	SIXBIT	/CONTIN/
	SIXBIT	/BYPASS/
	SIXBIT	/CONTRO/
	SIXBIT	/IMMEDI/
	SIXBIT	/DEFAUL/
	SIXBIT	/DDT/

OPCNT==.-OPTAB1

	EXP	HLT.05
DISTAB:	EXP	HLTCON
	EXP	HLTBY
	EXP	HLTCCN
	EXP	HLTICN
	EXP	HLTDDT
	EXP	HLTCON
	EXP	HLTBY
	EXP	HLTCCN
	EXP	HLTICN
	EXP	HLTDEF
	EXP	HLTDDT
;HLTOPT (cont'd)		Define error message table
;
;
;

%ERTAB:	[ASCIZ /H1	Indicator H1 is on/]
	[ASCIZ /H2	Indicator H2 is on/]
	[ASCIZ /H3	Indicator H3 is on/]
	[ASCIZ /H4	Indicator H4 is on/]
	[ASCIZ /H5	Indicator H5 is on/]
	[ASCIZ /H6	Indicator H6 is on/]
	[ASCIZ /H7	Indicator H7 is on/]
	[ASCIZ /H8	Indicator H8 is on/]
	[ASCIZ /H9	Indicator H9 is on/]
	[ASCIZ /H0	All halt indicators have been displayed/]
	[ASCIZ /11	Square root of a negative number asked/]
	[ASCIZ /12	Overflow during divide/]
	[ASCIZ /13	Division by zero attempted/]
	[ASCIZ /14	Zero, negative, or invalid array index/]
	[ASCIZ /15	Table out of sequence/]
	[ASCIZ /16	No table data found/]
	[ASCIZ /17	Too much data for table/]
	[ASCIZ /18	Terminal errors in RPG source/]
	[ASCIZ /19	Warning errors in RPG source/]
	[ASCIZ /10	No primary or secondary files opened/]
	[ASCIZ /1A	Exceeded specified object core/]
	[ASCIZ /1C	Invalid call to RPG Halt routine/]
	[ASCIZ /1E	End-of-file on demand file/]
	[ASCIZ /1F	Attempting to access beyond extent/]
	[ASCIZ /1H	Attempting to add duplicate key/]
	[ASCIZ /1J	Attempting to add key in wrong order/]
	[ASCIZ /1L	Key modified by record update or invalid record update operation/]
	[ASCIZ /1P	1P forms allignment/]
	[ASCIZ /1U	Record not found. Key not in index or record number to large/]
	[ASCIZ /1Y	Invalid response to display/]
	[ASCIZ /1	Prepare for table output/]
	[ASCIZ /J1	Record out of sequence/]
	[ASCIZ /L1	File out of matching sequence/]
	[ASCIZ /U1	Unidentified record/]
	[ASCIZ /J0	Multiple output to MFCM combined file/]
	[ASCIZ /U0	RPG compiler error/]
;H.01		Handle LR output for halt
;
;
;

H.01:	MOVEI	TC,155			; get L1
	PUSHJ	PP,SINDT		; turn it on
	MOVEI	TG,12			; get count
	IDPB	TE,TB			; turn on L2-L9
	SOJN	TG,.-1			; keep looping until done
	MOVEI	TC,166			; get LR
	PUSHJ	PP,SINDT		; turn it on
	JRST	@TOTBAS##		; go do LR calcs
;H.99		Do table and array output
;
;
;

H.99:	MOVE	TA,ARRBAS		; get start of ARRTAB
	JUMPE	TA,H.100		; keep on going if none

H.99.4:	MOVEM	TA,CURARR		; save the pointer
	LDB	TB,AR.LDM		; get load/dump flag
	JUMPE	TB,H.99.3+1		; skip this one if load
	SWOFF	FALT!FUALT;		; turn off some flags
	SWON	FRSPEC;			; turn on some flags
	LDB	TB,AR.ALT		; get alternating pointer
	JUMPE	TB,H.99.6		; is not alternating if we jump
	MOVEM	TB,CURARP		; else save pointer
	SWON	FALT;			; and set flag

H.99.6:	LDB	TA,AR.FIL		; get OTFTAB pointer
	MOVEM	TA,CUROTF		; store
	LDB	OPTR,OT.BFP		; get pointer to buffer
	HRLI	OPTR,440600		; make into byte pointer
	MOVE	TA,CURARR		; get ARRTAB pointer
	LDB	IPTR,AR.PNT		; get pointer to array
	LDB	CNTA,AR.OCC		; get size of array
	TSWF	FALT;			; alternating?
	  IMULI	CNTA,2			; yes - double size

H.99.2:	LDB	CNTR,AR.EPR		; get entries per record

H.99.5:	TSWT	FALT;			; alternating?
	  JRST	H.99.0			; No -
	TSWC	FUALT;			; yes - switch tables
	EXCH	IPTR,CURARP		; swap pointers

H.99.0:	LDB	CNT,AR.SIZ		; get size of an entry
	TSWF	FUALT;			; using alternate?
	  LDB	CNT,AR.ASZ		; yes - get alternate size

H.99.1:	ILDB	TB,IPTR			; get a character from an array
	IDPB	TB,OPTR			; output to buffer
	SOJG	CNT,H.99.1		; loop until field is output
	SOJLE	CNTA,H.99.3		; jump if all done with array
	SOJG	CNTR,H.99.5		; else loop until EPR = 0
	PUSHJ	PP,H.99.8		; then output the buffer
	JRST	H.99.2			; then take the big loop
;H.99 (cont'd)
;
;
;

H.99.3:	PUSHJ	PP,H.99.8		; output a buffer full
	LDB	TB,AR.LAS		; was this the last entry?
	JUMPN	TB,H.100		; jump if yes
	ADDI	TA,SZ.ARR		; else increase pointer
	JRST	H.99.4			; and try again

H.99.8:	SPUSH	<IPTR,CNTA>		; save some pointers
	PUSHJ	PP,OU.09		; do some output
	LDB	TB,OT.DEV		; get device
	CAIL	TB,3			; printer?
	CAILE	TB,5			; or console?
	  JRST	H.99.7			; no -
	MOVEI	TB,1			; yes - get space count
	PUSHJ	PP,SPOUT		; and output a space

H.99.7:	LDB	OPTR,OT.BFP		; get pointer to the file buffer
	HRLI	OPTR,440600		; make into byte pointer
	MOVE	TA,CURARR		; restore pointer to ARRTAB
	SPOP	<CNTA,IPTR>		; restore a bunch of pointers
	POPJ	PP,			; and exit
;H.100		Handle standard Halt
;
;
;

H.100:
IFN STATS,<
	MSTIME	TA,			; GET TIME OF DAY
	MOVEM	TA,TB			; TEMP STORE
	SUB	TA,%TIME1		; GET ELAPSED SINCE LAST TIME
	ADDM	TA,%TIMER		; ADD TO TOTAL FOR RUNTIME SYS
	SETZ	TA,			; GET JOB
	RUNTIM	TA,			; GET RUNTIME
	MOVE	TC,TA			; TEMP STASH
	SUB	TA,%RTIM1		; CALCULATE NEW TIME
	ADDM	TA,%RTIMR		; ADD TO TOTAL
	SUB	TB,%TIME0		; GET TOTAL ELAPSED FOR BOTH
	SUB	TB,%TIMER		; CALCULATE TIME FOR PROGRAM
	MOVEM	TB,%TIMEP		; STORE
	SUB	TC,%RTIM0		; GET TOTAL CPU TIME USED
	SUB	TC,%RTIMR		; CALCULATE AMOUNT USED BY PROG
	MOVEM	TC,%RTIMP		; STASH
	OUTSTR	[ASCIZ /
Total elapsed time: /]
	MOVE	TE,%TIMER		; GET TIME USED BY RUNTIME
	ADD	TE,%TIMEP		; CALCULATE TOTAL
	PUSHJ	PP,TIMOUT		; OUTPUT IT
	OUTSTR	[ASCIZ /	CPU time:       /]
	MOVE	TE,%RTIMR		; GET RUNTIME OF RUNTIME SYS
	ADD	TE,%RTIMP		; ADD IN PROG RUNTIME
	PUSHJ	PP,TIMOUT		; OUTPUT IT
	OUTSTR	[ASCIZ /
Elapsed in program: /]
	MOVE	TE,%TIMEP		; GET AMOUNT
	PUSHJ	PP,TIMOUT		; OUTPUT
	OUTSTR	[ASCIZ /	CPU in program: /]
	MOVE	TE,%RTIMP		; GET AMOUNT
	PUSHJ	PP,TIMOUT		; OUTPUT IT
	OUTSTR	[ASCIZ /
Elapsed in runtime: /]
	MOVE	TE,%TIMER		; GET AMOUNT
	PUSHJ	PP,TIMOUT		; OUTPUT IT
	OUTSTR	[ASCIZ /	CPU in runtime: /]
	MOVE	TE,%RTIMR		; GET IT
	PUSHJ	PP,TIMOUT		; OUTPUT IT
	OUTSTR	[ASCIZ /

/]
;H.100 (cont'd)
;
;
;

	MOVE	TE,%INDC##		; GET NUMBER OF TRIES
	PUSHJ	PP,TABD2		; OUTPUT
	OUTSTR	[ASCIZ / calls to INDC, /]
	MOVE	TE,%INDCT##		; GET NUMBER OF SUCCESSES
	PUSHJ	PP,TABD2		; OUT WITH IT
	OUTSTR	[ASCIZ / of which were successful, average = /]
	MOVE	TA,%INDCT		; GET NUMBER OF HITS
	IMULI	TA,^D10000		; MAKE SIGNIFICANT
	IDIV	TA,%INDC		; MAKE A PERCENTAGE
	PUSHJ	PP,PERCNT		; OUTPUT
	OUTSTR	[ASCIZ /% successful.
/]
	MOVE	TE,%INDC2		; GET # OF CALLS TO CKIND
	PUSHJ	PP,TABD2		; OUTPUT IT
	OUTSTR	[ASCIZ / calls to CKIND

/]
	MOVE	TA,%RTIMR		; GET CPU OF RUNTIME SYS
	IMULI	TA,^D10000		; WILL YIELD XX.XX%
	MOVE	TE,%RTIMR		; GET RUNTIME
	ADD	TE,%RTIMP		; ADD IN PROGRAM
	IDIV	TA,TE			; GET PERCENTAGE
	PUSHJ	PP,PERCNT		; OUTPUT IT
	OUTSTR	[ASCIZ /% of total time was spent in runtime sys
/]
	MOVE	TA,%RTIMI##		; GET TIME SPENT IN INDC
	IMULI	TA,^D10000		; MAKE IT COUNT
	IDIV	TA,%RTIM0		; GET XX.XX%
	PUSHJ	PP,PERCNT		; OUTPUT IT
	OUTSTR	[ASCIZ /% of total time was spent in INDC.
/]
	MOVE	TA,%RTIMC##		; GET RUNTIME IN CKIND
	IMULI	TA,^D10000		; GET APPROPRIATE PRECISION
	IDIV	TA,%RTIM0		; GET PERCENTAGE OF TOTAL RUNTIME
	PUSHJ	PP,PERCNT		; OUTPUT IT
	OUTSTR	[ASCIZ /% of total time was spent in CKIND
/]
	>
	PUSHJ	PP,STOPR.##		; use standard CBLIO exit routine
IFN STATS,<

;ROUTINE TO TYPE TIME IN TE
;
;TIME IS GIVEN IN MILS
;

TIMOUT:	ADDI	TE,5			; ROUND UP BY 5 MILS
	IDIVI	TE,^D1000		; CONVERT TO SECONDS
	MOVEI	TC,(TF)			; SAVE REMAINDER ROUNDED
	PUSHJ	PP,TABD2		; PRINT SECONDS

TIMO2:	MOVEI	CH,"."			; PRINT FRACTIONS OF A SECOND
	OUTCHR	CH
	MOVE	TE,TC
	IDIVI	TE,^D100
	MOVEI	CH,"0"(TE)
	OUTCHR	CH
	MOVE	TE,TF
	IDIVI	TE,^D10
	MOVEI	CH,"0"(TE)
	OUTCHR	CH
	POPJ	PP,


;PRINT OUT FIVE DECIMAL DIGITS

TABD2:	MOVEI	TB,5
	IDIVI	TE,12
	PUSH	PP,TF
	SOJG	TB,.-2

	MOVEI	TB,4
	JUMPE	TE,.+4			; MORE THAN 5 DIGITS?
	IDIVI	TE,12			; YES - KEEP CONVERTING
	PUSH	PP,TF
	AOJA	TB,.-3

	MOVEI	CH," "

TABD3:	POP	PP,TE			; SUPRESS LEADING ZEROES
	JUMPN	TE,TABD5
	OUTCHR	CH
	SOJG	TB,TABD3

TABD4:	POP	PP,TE
TABD5:	MOVEI	CH,"0"(TE)
	OUTCHR	CH
	SOJGE	TB,TABD4
	POPJ	PP,

	>
IFN STATS,<

;ROUTINE TO OUTPUT PERCENTAGE CONTAINED IN AC TA

PERCNT:	MOVEI	TC,4
	IDIVI	TA,^D10
	PUSH	PP,TB
	SOJG	TC,.-2

	MOVEI	TC,3
	JUMPE	TA,.+4
	IDIVI	TA,12
	PUSH	PP,TB
	AOJA	TC,.-3

	MOVEI	TD,2			; TWO LEADING POSITIONS

PER1:	POP	PP,TE
	JUMPN	TE,PER3
	SOJE	TD,PER4
	SOJG	TC,PER1

PER2:	POP	PP,TE
PER3:	MOVEI	CH,"0"(TE)
	OUTCHR	CH
	SOJN	TD,.+2
	OUTSTR	[ASCIZ /./]
	SOJGE	TC,PER2
	POPJ	PP,

PER4:	MOVEI	CH,"."
	OUTCHR	CH
	JRST	PER3

	>
SUBTTL	UUO Routines

;GTDATE		Routine to fetch current date in EDIT format
;
;
;

GTDATE:	PUSHJ	PP,RSYEAR		; get the year
	PUSHJ	PP,DATFDG		; convert to useable number
	MOVEM	TD,UYEAR##		; store it
	PUSHJ	PP,RSMON		; get the month
	PUSHJ	PP,DATFDG		; convert
	MOVEM	TD,UMON##		; save it
	PUSHJ	PP,RSDAY		; get the day
	PUSHJ	PP,DATFDG		; fudge it
	MOVEM	TD,UDAY##		; save it too
	MOVE	TD,UMON			; get month
	LSH	TD,^D12			; make room, make room
	ADD	TD,UDAY			; add in the day
	LSH	TD,^D12			; shift again
	ADD	TD,UYEAR		; make it MMDDYY
	MOVEM	TD,UDATE##		; save the whole thing
	POPJ	PP,			; and exit

DATFDG:	IDIVI	TC,^D10			; get the juicy parts
	ADDI	TD,'0'			; convert remainder to sixbit
	LSH	TC,6			; get quotient shifted
	ADDI	TD,'0'_6(TC)		; and convert that to sixbit too
	POPJ	PP,			; exit
;RSVWD.		Routines to handle reserved word processing
;
;Call routine with AC16 set up as follows:
;
;	Bits 18-21	The AC we should store/get
;	Bits 22-25	The size of the field
;	Bits 26-29	The reserved word code:
;				0	UDATE
;				1	UMONTH
;				2	UDAY
;				3	UYEAR
;				4	PAGE
;				5	PAGE1
;				6	PAGE2
;
;	Bit 30		Is 1 if we want to store
;

RSVWD.:	TLNE	AC16,1B30		; are we storing?
	  JRST	RSVST			; yes - go handle
	LDB	TC,[POINT 4,AC16,29]	; get the reserved word number
	XCT	RSVTB(TC)		; get the word
	LDB	TD,[POINT 4,AC16,21]	; get the AC we're dealing with
	LDB	TE,[POINT 4,AC16,25]	; get the field size
	MOVEM	TC,(TD)			; store the word
	CAIG	TE,^D10			; double precision
	  POPJ	PP,			; no - exit
	SETZM	(TD)			; yes - zap high order
	MOVEM	TC,1(TD)		; and store low order
	POPJ	PP,			; then exit

RSVST:	LDB	TC,[POINT 4,AC16,29]	; get reserved word number
	LDB	TD,[POINT 4,AC16,21]	; get the AC
	LDB	TE,[POINT 4,AC16,25]	; get the field size
	MOVE	TF,(TD)			; get one word
	CAILE	TE,^D10			; was it the right one?
	  MOVE	TF,1(TD)		; no - get low part of double precision
	MOVEM	TF,@PGTAB-4(TC)		; store number
	POPJ	PP,			; exit

PGTAB:	EXP	PAGE##
	EXP	PAGE1##
	EXP	PAGE2##

RSVTB:	PUSHJ	PP,RSDATE		; go get date
	PUSHJ	PP,RSMON		; go get month
	PUSHJ	PP,RSDAY		; go get day
	PUSHJ	PP,RSYEAR		; go get year
	MOVE	TC,PAGE			; get the page number
	MOVE	TC,PAGE1		; get the page number
	MOVE	TC,PAGE2		; get the page number
;RSDATE		Date routines for RSVWD. and others
;
;
;

RSDATE:	DATE	TD,			; get the date
	IDIVI	TD,^D31			; get days
	MOVEI	TC,1(TE)		; correct and get into TC
	IMULI	TC,^D100		; shift over into middle position
	IDIVI	TD,^D12			; get month
	ADDI	TE,1			; correct it
	IMULI	TE,^D10000		; shift it over
	ADD	TC,TE			; add in month
	MOVEI	TE,^D64			; get the base year
	ADD	TE,TD			; plus years since then
	CAIL	TE,^D100		; is it year 2000+ ?
	  SUBI	TE,^D100		; yes - make it 00+
	ADD	TC,TE			; add in the year
	POPJ	PP,			; exit

RSMON:	DATE	TD,			; get date
	IDIVI	TD,^D31			; get days
	IDIVI	TD,^D12			; get the month
	MOVEI	TC,1(TE)		; get it for real
	POPJ	PP,			; and exit

RSDAY:	DATE	TD,			; get the date
	IDIVI	TD,^D31			; get day
	MOVEI	TC,1(TE)		; correct it 
	POPJ	PP,			; exit

RSYEAR:	DATE	TD,			; get the date
	IDIVI	TD,^D31*^D12		; get the year
	MOVEI	TC,^D64			; get our base year
	ADD	TC,TD			; get years since 1900
	CAIL	TC,^D100		; all the way into 2000?
	  SUBI	TC,^D100		; yes - well make it years since 2000
	POPJ	PP,			; and exit
;EXCPT.		Routine to perform exception output for EXCPT verb
;
;
;

EXCPT.:	SETOM	ECKS			; set the flag
	SETZ	SW,			; [134] zap the switch register
	PUSHJ	PP,OUTPT		; do the output
	SETZM	ECKS			; turn off for next person
	POPJ	PP,			; and thats all there is to it
;.READ.		Handle the READ verb
;
;
;

.READ.:	HRRZ	TA,(PA)			; get the OTFTAB address
	MOVEM	TA,CUROTF		; stash for later
	LDB	TF,OT.CHN		; get the psuedo-channel
	IMULI	TF,CHNSIZ		; multiply by channel size
	ADD	TF,CHNBAS		; add in base address
	SKIPE	EOF(TF)			; file already at EOF?
	  JRST	READ.1			; yes -
	PUSHJ	PP,INPT			; go do the read
	  JRST	%%H.1U			; error -
	MOVE	PA,.JBUUO		; [126] restore PA
	SKIPE	EOF(TF)			; at EOF now?
	  JRST	READ.1			; yes -
	PUSHJ	PP,RIIGET##		; identify the record
	JUMPE	TD,READ.2		; couldn't identify record
	MOVE	TC,TD			; get indicator inro proper AC
	MOVE	TB,RIIPDL##		; get RII PDL pointer
	PUSH	TB,TC			; save the RII on the stack
	MOVEM	TB,RIIPDL		; and save the pointer
	PUSHJ	PP,SINDT		; turn it on
	MOVE	TF,CURCHN		; get CHNTAB pointer
	MOVE	TB,CURICH##		; likewise with ICHTAB pointer
	MOVEM	TB,IPC(TF)		; spacemen of the IPC
	MOVE	TA,CUROTF		; restore OTFTAB pointer
	PUSHJ	PP,DATAV.##		; make data available
	HLRZ	TC,(PA)			; get the EOF indicator
	JUMPE	TC,RET.1		; exit if none
	PJRST	SINDF##			; else turn it off

READ.1:	HLRZ	TC,(PA)			; get EOF indicator
	SKIPE	TC			; is there one?
	  PJRST	SINDT			; yes - turn it on and exit
	PUSHJ	PP,%%H.1E		; take error trip
	POPJ	PP,			; in case of continue

READ.2:	JRST	%%H.U1			; error - can't continue
;CHAIN.		Routine to handle the CHAIN UUO
;
;Call:		MOVE	AC16,[CHAIN.,,ADDR]
;
;
;	ADDR:	Byte pointer to symbolic key
;		Size in bits 0-9, Error indicator in bits 10-17, OTFTAB link in RH
;
;If byte pointer is zero then AC1 and AC2 contain relative record key.
;
;

CHAIN.:	HRRZ	TA,1(PA)		; get OTFTAB link
	MOVE	TB,(PA)			; get byte pointer
	JUMPE	TB,CHAN.4		; jump if relative record key
	LDB	TC,OT.FTB		; get FTBTAB link
	MOVE	TC,F.WBSK(TC)		; get pointer to symbolic key
	LDB	TD,[POINT 10,1(PA),9]	; get size of field

CHAN.0:	ILDB	CH,TB			; get a char from key
	IDPB	CH,TC			; stash where CBLIO can find it
	SOJG	TD,CHAN.0		; loop until done

CHAN.1:	LDB	TB,OT.TYP		; get type of file
	CAIN	TB,1			; output?
	  JRST	CHAN.3			; yes -
	LDB	TF,OT.CHN		; get psuedo-channel
	IMULI	TF,CHNSIZ		; times channel size
	ADD	TF,CHNBAS		; add in base address
	MOVEM	TA,CUROTF		; save OTFTAB pointer
	CAIE	TB,2			; [144] update file?
	  JRST	CHAN.5			; [144] no -
	MOVE	TB,(PA)			; [144] yes - get key byte pointer
	JUMPE	TB,CHAN.7		; [144] jump if relative record number
	LDB	TD,[POINT 10,1(PA),9]	; [144] else get field size
	MOVE	TC,[POINT 6,UPD(TF)]	; [144] and pointer to update key stash area

CHAN.6:	ILDB	CH,TB			; [144] get character of key
	IDPB	CH,TC			; [144] stash in update stash area
	SOJG	TD,CHAN.6		; [144] do so until entire field is stashed
	JRST	CHAN.5			; [144] then go do the read

CHAN.7:	LDB	TD,[POINT 10,1(PA),9]	; [144] here if rel record num -- get size
	MOVE	TB,AC1			; [144] try for single precision first
	CAILE	TD,^D10			; [144] is it?
	  MOVE	TB,AC2			; [144] no - get low order of double precision
	MOVEM	TB,UPD(TF)		; [144] and store key for update
;CHAIN.	(cont'd)
;
;
;

CHAN.5:	PUSH	PP,PA			; [046] [144] save AC16 (INPT messes it)
	PUSHJ	PP,INPT			; do the input
	  JRST	CHAN.2			; invalid key
	POP	PP,PA			; [046] restore AC16
	PUSHJ	PP,RIIGET		; identify record
	JUMPE	TD,READ.2		; error if couldn't
	MOVE	TC,TD			; get RII into proper AC
	MOVE	TB,RIIPDL		; get the RII PDL pointer
	PUSH	TB,TC			; save this RII on the RII stack
	MOVEM	TB,RIIPDL		; and resave the pointer
	PUSHJ	PP,SINDT		; set the indicator
	MOVE	TF,CURCHN		; get CHNTAB pointer
	MOVE	TB,CURICH		; and ICHTAB pointer
	MOVEM	TB,IPC(TF)		; and store input pointer
	MOVE	TA,CUROTF		; get back OTFTAB pointer
	PUSHJ	PP,DATAV.		; make data available
	LDB	TC,[POINT 8,1(PA),17]	; get error indicator
	JUMPE	TC,RET.1		; ok if none
	PJRST	SINDF			; else turn it off

CHAN.2:	POP	PP,PA			; [046] get parameter pointer back
	LDB	TC,[POINT 8,1(PA),17]	; get error indicator
	JUMPN	TC,SINDT		; ok if we have one
	PUSHJ	PP,%%H.1U		; error - tell turkey
	POPJ	PP,			; just in case we return

CHAN.3:	SWON	FREAD;			; turn on weird read flag
	SETOM	DEE			; we want detail output
	PUSHJ	PP,OU.00		; go output some stuff
	SWOFF	FREAD;			; turn off weird flag
	SETZM	DEE			; reset type flag
	POPJ	PP,			; and exit
;CHAIN. (cont'd)
;
;
;

CHAN.4:	LDB	TC,OT.FTB		; get FTBTAB pointer
	LDB	TD,[POINT 10,1(PA),9]	; get size
	MOVE	TB,AC1			; get relative key
	CAILE	TD,^D10			; that the right AC?
	  MOVE	TB,AC2			; no - is double precision
	MOVEM	TB,@F.RACK(TC)		; stash in actual key table for CBLIO
	JRST	CHAN.1			; go do rest



;TIME. & TIMED.		Routine to return the time-of-day and date in binary
;
;Always returns the value in AC3 & AC4
;
;

TIME.:	SKIPA	TA,[DEC 6]		; get character count for just time
TIMED.:	MOVEI	TA,^D12			; get count for time and date
	PUSH	PP,TA			; save for later
	PUSHJ	PP,TODAY.##		; go get date from CBLIO
	EXCH	AC0,AC1			; make it time, date
	MOVE	TA,[POINT 0,AC0]	; get pointer to it
	POP	PP,TB			; restore character count
	DPB	TB,[POINT 10,TA,17]	; stash into byte pointer
	MOVEM	TA,TODTMP##		; stash in temp storage
	MOVE	AC16,[Z AC3,TODTMP]	; get parameter word
	PJRST	GD6.##			; and go convert and exit
;DEFINE EXTERNALS

EXTERNAL CHNBAS,INDBAS,OTFBAS,OTFSIZ,CUROTF,CURREC,CUROCH
EXTERNAL FILEXT,OVIND,OVTIM
EXTERNAL AITCH,DEE,TEE,ECKS,KEYBUF,LOKEY,HIKEY
EXTERNAL XFOTF,READF,PPN
EXTERNAL KEYFLG,LPSBUF,BLTHLD

EXTERNAL EDIT.,A.00,UUO.,SKIND

EXTERNAL OT.TYP,OT.DES,OT.PRO,OT.ORG,OT.RAF,OT.DEV,OT.EOF
EXTERNAL OT.KYP,OT.BLK,OT.SEQ,OT.BUF,OT.AST,OT.REW,OT.EXT
EXTERNAL OT.ADD,OT.OVI,OT.OVL,OT.LPP,OT.EXI,OT.COR,OT.CRS
EXTERNAL OT.ADP,OT.CHN,OT.BFP,OT.BSZ,OT.BSC,OT.OPC,OT.IPC
EXTERNAL OT.LAS,OT.CHI,OT.KYL,OT.NAM

EXTERNAL OC.FLD,OC.SIZ,OC.DEC,OC.PRI,OC.PRO,OC.STR,OC.STP
EXTERNAL OC.ORT,OC.ADD,OC.FOV,OC.SKB,OC.SKA,OC.SPB,OC.SPA
EXTERNAL OC.END,OC.IDX,OC.OCC,OC.SRC,OC.NXR,OC.NXF,OC.IND
EXTERNAL OC.STS,OC.EDT

EXTERNAL ID.OR,ID.NOT,ID.IND,ID.POS,ID.END,ID.RII

EXTERNAL PFRST.,IFRST.,ILAST.


	END