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 B2+B11+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 ; 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 ; 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 ; 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. 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 ; 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 ; 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