Trailing-Edge
-
PDP-10 Archives
-
decuslib10-10
-
43,50517/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