Trailing-Edge
-
PDP-10 Archives
-
CFS_TSU04_19910205_1of1
-
update/cblsrc/cblio.mac
There are 23 other files named cblio.mac in the archive. Click here to see a list.
;IGUANA:<8X-COBOL.EDITED>CBLIO.MAC.28, 20-Mar-89 14:52:05, Edit by KSTEVENS
;IGUANA:<8X-COBOL.EDITED>CBLIO.MAC.27, 20-Mar-89 14:11:02, Edit by KSTEVENS
; UPD ID= 1620 on 5/22/84 at 9:19 AM by HOFFMAN
TITLE CBLIO for COBOL OTS version 13
SEARCH COPYRT
SALL
COPYRIGHT (C) 1974, 1986 BY DIGITAL EQUIPMENT CORPORATION
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
;EDITS
;NAME DATE COMMENTS
;V13************
;RLF 06-JUL-90 [1207] If ISAM file is ASCII but key is unsigned, make
; it work the same way as non-numeric.
;KWS 25-APR-88 [1202] To generate appropriate error message when byte count
; to index file is set to zero in the middle of the
; program.
;KWS 27-JAN-88 [1201] Fix edit 1166.
;RLF 04-FEB-87 [1176] Reverse part of 1137 so BLT won't trash
; location for name string
;RLF 14-OCT-86 [1171] Don't output CRLF before first ASCII record
;RLF 08-OCT-86 [1167] Flag WANT8. was not checked correctly
;MEM 01-OCT-86 [1166] PDL size is off by 20
;RLF 30-SEP-86 [1165] COMPT. UUO failed because DF.DEV is corrupted
;RLF 03-SEP-86 [1164] Buffer is cleared if OPEN EXTEND with SAME AREA
;KWS 18-NOV-85 [1152] Make sure that the channel number is set up correctly
; when using Declaratives...
;MJC 03-SEP-85 [1151] Clear dump mode IOWD in RH of UOUT. on invalid key
;KWS 01-JUL-85 [1147] Fix problem with catching "File being modified" error.
;JSM 22-APR-85 [1143] Change where progs. fail if missing ISAM files
;MJC 28-MAR-85 [1141] Search 9 char VALUE OF ID for a separator before
; assuming it is the old style.
;BCM 27-Mar-85 [1140] Make PA1050 allocate buffers in prealloc area.
;KWS 28-MAR-85 [1137] Fix the lookup of overlay files.
;MJC 03-JAN-85 [1133] Make file-not-found create on the right device
;KWS 15-OCT-84 [1131] Fix OPEN I-O FILENAME. so it doesn't do SMU.
;KWS 12-SEP-84 [1130] Add conversion factor for reading sequential i-o.
;JEH 22-MAY-84 [1126] New feature test switch and code to print blank
; ascii text lines
;JSM 14-MAY-84 [1125] Test on 'RPTW.' before generating +2 return from
; WADV. to Report Writer routine
;JEH 10-MAY-84 [1121] READ NEXT after 2 REWRITES fails, flags reset at
; wrong time
;JBB 27-APR-84 [1120] Don't get a channel number when opening a file
; assigned to LPT:
;RLF 22-MAR-84 [1113] Make use procedure works with filename-1 OPEN
;JEH 19-MAR-84 [1112] No <CR> at end of std-ascii tape
;JBB 21-DEC-83 [1105] Put a '?' in front of warning to make it FATAL.
;JBB 20-DEC-83 [1104] Remove SETEOF warning message and set max byte count
;JSM 09-NOV-83 [1103] On Fake Read for SMU Retain on TOPS-10, check for
; EOF Return and don't cause program failure if so.
SUBTTL PICK UP UNIVERSALS AND SET UP JOBDAT.
SEARCH LBLPRM,COBVER ;DEFINE PARAMETERS.
%%LBLP==:%%LBLP
SEARCH COMUNI
%%COMU==:%%COMU
INFIX%
SEARCH FTDEFS ;FILE-TABLE DEFINITIONS
%%FTDF==:%%FTDF
SEARCH UUOSYM
IFN TOPS20,< SEARCH MONSYM, MACSYM>
IFE TOPS20,< SEARCH MACTEN>
IFN TOPS20,<OF%RDU==1B23 ;[667] READ UNRESTRICTED>
IFE TOPS20,<UU.RRC==1B6 ;UNTIL 7.01 IS RELEASED>
.COPYRIGHT ;Put standard copyright statement in REL file
LOC 124 ;.JBREN
EXP RENDP ;TO FORCE A DUMP.
LOC 137 ;.JBVER
EXP LBLVER
IFNDEF SIRUS,<SIRUS==0> ; [403] SPECIAL CODE FOR SIRUS
IFNDEF ISTKS,<ISTKS==0> ;TYPE # OF IN'S AND OUT'S
DEFINE SAVACS,<
MOVEM 0,RACS
MOVE 0,[1,,RACS+1]
BLT 0,RACS+17
>
DEFINE RSTACS,<
MOVE 0,[RACS+1,,1]
BLT 0,17
MOVE 0,RACS
>
HISEG
SALL
MLON
SUBTTL CONSTANTS
;AC ASSIGNMENTS
FLG=7
C=11
I12=12
LVL=13
FLG1=14
I16=16
; USE PROCEDURE TABLE OFFSET VALUES
USESEC==5 ; USE PROCEDURE TABLE SECTION SIZE
EXTUSE==^D15 ; OFFSET TO EXTEND ERROR USE PRODECURE
;[566] LOOKUP BLK OFFSETS
LKPSIZ==3 ;[566] OFFSET TO FILE SIZE RETURNED IN LOOKUP BLOCK
;MTOPR CONSTANTS
MTOSIZ==15 ;SIZE OF TEMP TABLE USED BY .MORLI MTOPR FUNCTION
;COMPT. UUO FUNCTIONS
IFN TOPS20,<
CMP.1==1 ;SIMULATE LOOKUP OR ENTER
CMP.3==3 ;TRANSLATE PPN TO STRING
CMP.10==10 ;GET JFN FROM CHANNEL NUMBER
CMP.13==13 ;OPEN EXTEND
>
;MTA CONSTANTS
IFNDEF .TFKD2,<.TFKD2==6> ; [645] DX20 CONTROLLER CODE FOR TAPOP.
MXTPRC==20000 ;MAX. MTA REC SIZE (IN WORDS)
MINMTA==4 ;MINIMUM MTA OUTPUT SIZE
; OFFSETS INTO LABEL INFORMATION BLOCK
LABTYP==1 ; TO LABEL TYP
IFN TOPS20,<
LABFOR==4 ; LABEL FORMAT CHARACTER
>
IFE TOPS20,<
LABFOR==.TPREC ; LABEL FORMAT CODE
LABFMS==0 ; FORMS CONTROL HERE
>
; BIT DEFINITIONS FOR LABELED TAPE FORMAT
FRMATU==10 ; "U" FORMAT
FRMATS==4 ; "S" FORMAT
FRMATD==2 ; "D" FORMAT
FRMATF==1 ; "F" FORMAT
;DEF SYMBOLS FOR DISK BLOCK SIZE
DSKBSZ==200 ;SIZE OF A DISK BLOCK (BUFFER)
DSKMSK==177 ;MASK FOR BITS TO RIGHT OF DSKBSZ
DFLTBF==2 ; DEFAULT NUMBER OF SEQ (RING) BUFFERS
BYTCTW==12 ;[1104] BYTE COUNT WORD IN FILE'S FDB
;FLAGS IN LEFT SIDE OF "FLG" & F.WFLG(I16) AFTER RESET.
; **WARNING** DO NOT DISTURB DDM??? OR CDM???
DDMASC==400000 ;DEVICE DATA MODE IS ASCII
DDMSIX==200000 ;DEVICE DATA MODE IS SIXBIT
DDMEBC==100000 ;DEVICE DATA MODE IS EBCDIC
DDMBIN==40000 ;DEVICE DATA MODE IS BINARY
OPNIN==20000 ;FILE IS OPEN FOR INPUT
OPNOUT==10000 ;FILE IS OPEN FOR OUTPUT
OPNIO==30000 ;[622] FILE IS OPEN FOR I-O
IOFIL==4000 ;[622] FILE IS AN INPUT/OUTPUT FILE
ATEND==2000 ;AN "EOF" WAS SEEN
CONNEC==1000 ;DEVICE & CORE DATA MODES DIFFER
NOTPRS==400 ;OPTIONAL FILE NOT PRESENT
RRUNER==200 ;RERUN DUMP AT END-OF-REEL
RRUNRC==100 ;RERUN DUMP VIA RECORD-COUNT
CDMASC==40 ;CORE DATA MODE IS ASCII
CDMSIX==20 ;CORE DATA MODE IS SIXBIT
CDMEBC==10 ;CORE DATA MODE IS EBCDIC
IDXFIL==4 ;ACCESS MODE IS INDEX-SEQUENTIAL
SEQFIL==2 ;ACCESS MODE IS SEQUENTIAL
RANFIL==1 ;ACCESS MODE IS RANDOM
;FLAGS IN LEFT SIDE OF FLG1 & D.F1(I16)
;BITS 0 THROUGH 3 ARE SET BY THE COMPILER (SEE FTDEFS)
;BITS 4 & 5 ARE USED FOR LABEL PROCESSING
NOTEST==2000 ;[276] SKIPE THE CONVERSION TEST AT ADJKEY
WSTB==1000 ;WRITE THE STATISTICS BLOCK
IIAB==400 ;INSERTION IS IN AUX BUFFER
TRYAGN==200 ;MAKE A SECOND PASS AT ALC01 OR DON'T AT VNDE
BVN==100 ;BUMP-VERSION-NUMBER SPLITTING A BLOCK
WSB==40 ;WRITE THE SAT BLOCK
BLK2==20 ;REQ FOR 2ND DATA BLOCK
SEQ==10 ;SEQUENTIAL READ
VERR==4 ;VERSION NUMBER DISCREPANCY BTWEEN INDEX LEVELS
WIVK==2 ;WRITE INVALID-KEY
FOPIDX==2 ;FILOP OF NAME.IDX IN PROGRESS
FOPERR==2 ; FILOP.UUO FAILED
RIVK==1 ;READ, RERIT OR DELET INVALID-KEY
EIX==1 ;ENTER OF NAME.IDX IN PROGRESS
IFN TOPS20,<
F1CLR==7777 ; THESE FLG1 FLAGS ARE CLEARED AT CLOSE TIME
>
IFE TOPS20,<
F1CLR==37777 ; THESE FLG1 FLAGS ARE CLEARED AT CLOSE TIME
>
; BITS IN LEFT HALF OF AC15 DURING WADV.
WDVADR==40 ; BIT18-35 IS THE ADDRESS OF THE ADVANCING COUNT
WDVBFR==20 ; =1 IF BEFORE ADVANCING
WDVPOS==10 ; POSITIONING
KEYSIZ==7777 ; MASK TO GET KEY SIZE FIELD OF ISAM KEY DESCRIPTOR
SUBTTL EXTERNALS.
ENTRY C.RSET ;MAKE SURE WE GET LOADED.
ENTRY DSPL.6,DSPL.7,DSPLY. ;FOR OVERLAYS
INTERN GDPSK ;[447]SIMULTANEOUS UPDATE
INTERN CHTAB ;[455] SIMULTANEOUS UPDATE
INTERN SEQFIL ;[455] SIMULTANEOUS UPDATE
INTERN F.BFAM, SAVNXT ;FOR SIM. UPDATE
INTERN FAKER.,IGSS,RANFIL,E.VRET
INTERN C.CLOS,DOPFS.,C.END,GETCH.,DSPL1.,MSOUT.,C.OPEN,OUTCH.
INTERN OUT6B.,OUTBF.,READ.,RSTAB.,STOPR.,C.STOP,TRAP.,WRITE.,WADV.,WRPW.
INTERN WADVV.,WRITV.
INTERN GOTO.,KILL.,PPOUT.,PPOT4.,SAVAC.,RSTAC.
INTERN KPROG. ;NO UNCONDITIONAL TRANSFER AT END OF PROGRAM
INTERN KDECL. ;NO UNCONDITIONAL TRANSFER AFTER DECLARATIVES
INTERN ILLC. ;RECURSIVE CALL
INTERN C.STRT,RDNXT.
INTERN DELET.,RERIT.,PURGE.
INTERN USOBJ,LVTST,LV2SK.,FOPIDX,NNTRY
INTERN LIBVR.,LIBSW.
INTERN CNTRY ;[650] MAKE INTERNAL FOR LSU
EXTERNAL LIBIMP ;CAUSES LIBREL ( LIBOL.LOW) TO BE LOADED FOR /R
; [440] REMOVE EXTERNAL SYMBOL FOR EDIT 414
EXTERNAL IIN,IOUT,ISETI,ISETO,ICLOS,IRELE,IGETS,IWAIT,IRNAM
EXTERNAL MWAIT.,MREW.,MREWU.,MBSPR.,MBSPF.,MADVR.,MADVF.,MWEOF.,MTIND.
EXTERNAL MERAS. ;[470]
EXTERNAL SOBOT.,SZBOT.,SZEOF.,SZEOT.
EXTERNAL UOPEN.,UENTR.,ULKUP.,UOBUF.,UIBUF.,UCLOS.,URELE.
EXTERNAL UOUT.,UIN.,USETS.,UGETS.,UWAIT.,URNAM.
EXTERNAL UOCAL.,OPNCH.,UOBLK.,NRSAV.,AUTOLB,TMP.BK
EXTERNAL UEBLK.,ULBLK.,TTOBP.,TTOBC.,TTOBF.,STDLB.
EXTERNAL REDMP.,TEMP.,TEMP.1,JSARR.,TEMP.2,SEGNO.,OVRBF.,FLDCT.,OVRIX.
EXTERNAL SHRDX. ;[556]
EXTERNAL NOCR.,PRGFLG,TTYOPN,ACSAV0,MXIE,IESAVE,MXBUF,AUXBUF,AUXIOW,AUXBNO,CMDLST,NEWBK1
EXTERNAL NEWBK2,OLDBK,MXBF,DRTAB,LRWA
EXTERNAL FS.ZRO,FS.FS,FS.EN,FS.BN,FS.RN,FS.UPD,FS.IGE,FS.IF,ISETS,FS.IEC
EXTERNAL CMPTER ;HOLD ERROR CODE FROM RETURN FROM COMPT. UUO
EXTERNAL MOVE.,PD6.,PD7.,C.D6D7,C.D7D6
EXTERNAL PD9.,C.D9D6,C.D9D7,C.D6D9,C.D7D9
EXTERNAL FRSTIC,LASTIC,PFRST.,UFRST.,ULAST.,IFRST.,ILAST.
EXTERNAL RELEN. ;[332]
EXTERN DATE.,DATE1.
EXTERNAL RN.PPN, RUN.TM, RN.DEV, RN.NAM ;[333]
EXTERNAL PUSHL.,CB.DDT,LEVEL.,%F.PTR,COBSW.,SBPSA.
EXTERNAL SU.RBP,SU.CL,SU.WR,SU.RD,SU.DL,SU.RW,SU.RR ;[1162]SIMULTANEOUS UPDATE
EXTERN FOP.BK,FOP.IS,FOP.DN,FOP.LB ;SIMULTANEOUS UPDATE
EXTERN SU.FRF ;FAKE READ FLAG
; NEXT RECORD BY KEY DURING READ OF
; RELATIVE FILE.
EXTERN .JBSA,.JBFF,.JBREL,.JBAPR,.JBTPC,.JBCNI,.JBDA,.JBOPC,.JBREN
EXTERNAL RET.1,RET.2,RET.3
EXTERNAL HLOVL. ;[346] XWD HIGHEST OVERLAY LOC , LOWEST LOC
EXTERNAL GD6.,GD7.,GD9.,GC3.,PD6.,PD7.,PD9.,PC3.,KEYCV. ;[370]
EXTERNAL FILES.,USES.,OVRFN.,TRAC1.
EXTERN FUSIA.,FUSOA.,FUSCP. ;[523] FILOP. ARG-BLOCK
SUBTTL RESET
;RESET IS CALLED WITH A JSP 14,C.RSET
$COPYRIGHT ;Put standard copyright statement in EXE file
LIBVR.: EXP LBLVER ;OTS VERSION NUMBER
LIBSW.: EXP SWSET% ;OTS ASSEMBLY SWITCHES
SRTVR.: EXP V%SORT## ;SORT VERSION NUMBER
C.RSET: JRST .+2 ;ENTRY FOR 'C.RSET'
JRST STOPR. ;ENTRY FOR 'STOP RUN'
CALLI ;RESET
MOVE AC1,(AC14) ; GET ADDRESS OF ENTRY POINT
MOVEM AC1,%F.PTR ; (%F.PTR)+1 IS ADR OF FILES.
IFE TOPS20,<
RUNTIM AC1, ;[346]GET THE RUNTIME.
>
IFN TOPS20,<
MOVNI AC1,5 ;GET RUNTIME FOR THIS JOB
RUNTM% ;IN MILLISECS
>
MOVEM AC1,RUN.TM ;[346]SAVE IT.
HRRZ AC1,.JBSA ;[START.]
MOVEM AC1,JSARR. ;SAVE FOR RRDMP
HRRZ AC1,.JBFF ;TO-1
CAMG AC1,.JBREL ;SKIP ILL-MEM-REF
SETZM (AC1) ;ZERO WORD
HRL AC1,AC1 ;FROM,,TO-1
ADDI AC1,1 ;FROM,,TO
HRRZ AC2,.JBREL ;UNTIL
CAIL AC2,(AC1) ;SKIP ILL-MEM-REF IF .JBFF = .JBREL
BLT AC1,(AC2) ;ZERO FREE COR
RESET1: MOVEI AC0,[OUTSTR [ASCIZ/?COBOL programs may only be started through
use of "GET and ST" or "RUN" monitor commands./]
EXIT] ;[1105] CONSIDER THIS FATAL
HRRM AC0,.JBSA
MOVE PP,[XWD PFRST.,IFRST.]
TLNE PP,777777 ;NO BLT IF PFRST. = 0 - LOW SEG WAS LOADED
BLT PP,ILAST. ;THE IO UUO'S
MOVEI AC10,MEMRY.## ;SET UP MEMRY. POINTER
MOVEM AC10,MEMRY%##
HRRZ AC10,(AC14) ;GET THE PROGRAM'S ENTRY POINT.
HRRZ AC10,1(AC10) ;GET THE ADDRESS OF %FILES.
MOVN PP,%PUSHL(AC10) ;GET THE PDL SIZE.
HRL PP,.JBFF ;START-LOC,,-LENGTH
MOVSS PP,PP ;POINTER IS SET UP.
;[1201]set .jbff to 20 above stack end to allow expansion on pdlov
ADDI AC10,20 ;[1166]LENGTH+20
ADDB AC10,.JBFF ;ADJUST .JBFF
IFN TOPS20,<
ADDI AC10,200 ;MAKE SURE THERE IS ENOUGH ROOM FOR .EXE SPEC
>
IORI AC10,1777 ;MOVE UP TO THE NEXT K BOUNDARY
CAMG AC10,.JBREL ;ARE WE BEYOND .JBREL?
JRST RESET2 ;NO, GO ON.
CORE AC10, ;YES, GO ASK FOR MORE CORE.
JRST GETSPK ;CAN'T HAVE ANY MORE, ERROR.
RESET2:
IFN TOPS20,<
;Store text string to file spec of .EXE file.
;This is used to re-initialize data in INITIAL programs.
HRRZ AC1,JSARR. ;GET A PAGE # (ORIGINAL START ADDRESS)
LSH AC1,-9
HRLI AC1,.FHSLF
RSET2A: RPACS% ;FIND OUT ABOUT IT
ERJMP RSET2B ;GIVE UP
TXNN AC2,PA%PEX ;IF PAGE DOESN'T EXIST
JRST RSET2B ;GIVE UP
TXNE AC2,PA%PRV ;IF PRIVATE PAGE
AOJA AC1,RSET2A ;TRY NEXT ONE
RMAP% ;GET JFN
ERJMP RSET2B ;ERROR
HLRZ AC2,AC1 ;JFN
HRRO AC1,.JBFF ;WHERE TO STORE STRING
MOVX AC3,<<FLD .JSAOF,JS%DEV>!<FLD .JSAOF,JS%DIR>!<FLD .JSAOF,JS%NAM>!<FLD .JSAOF,JS%TYP>!<FLD .JSAOF,JS%GEN>!JS%PAF> ;[1137]
JFNS% ;GET STRING
ERJMP RSET2B ;ERROR
HRRZI AC1,1(AC1) ;GET NEXT FREE LOC
EXCH AC1,.JBFF ;AND UPDATE IT
HRROM AC1,EXJFN.## ;STORE PTR TO TEXT
RSET2B:>
;SET FLAGS TO TRAP ON
MOVEI AC0,TRAP. ;[312] INTERUPT ROUTINE ADR
MOVEM AC0,.JBAPR ;[312]
MOVEI AC0,AP.POV!AP.ILM!AP.NXM ;[312] PDLOV - MPVIO - NXM
APRENB AC0, ;[312] APRENB UUO
PUSH PP,AC14 ;SO WE CAN PRINT PC ON ERRORS
PUSHJ PP,RSAREN ;[312] INIT .JBSA AND .JBREN
PUSHJ PP,OUTBF1 ;SETUP TTY BYTE-POINTER AND BYTE-COUNT
PUSHJ PP,RSTLNK ;LINK ALL SUB-PROGRAM'S FILE-TABLES
PUSHJ PP,SUSPC ;COMPUTE SPACE REQUIRED FOR SIMULTANEOUS
;UPDATE, AND GET IT
SKIPE AC1,OVRFN. ;DOES OVERLAY FILE HAVE TO BE OPENED?
PUSHJ PP,SETOVR ;YES, SET UP OVERLAY FILE
SETZM RMFLG.## ;CLEAR "RMS NEEDED" FLAG
PUSHJ PP,RSTAB. ;ASSIGN THE BUFFER AREA
; THIS WILL SET "RMFLG." TO -1 IF ANY RMS
; FILES ARE DEFINED IN THE PROGRAM
IFE TOPS20,<
PUSHJ PP,SETALB ;SET AUTOLB IF AUTO MTA LABEL PROCESSING
>
POP PP,(PP) ;CLEAN UP STACK
SKIPE RMFLG.## ;SKIP IF RMS NOT USED
PUSHJ PP,RMSGET## ; ** GO GET RMS **
SETOM INRST.## ;[530] SET END OF RESET FLAG
MOVE AC10,COBSW. ;GET COMPILER ASSEMBLY SWITCHES
TXNE AC10,SW.STB ;WANT TO SUPPRESS TRAILING BLANKS
SETOM SUPTB.## ;YES, SAVE FOR LATER TESTS
IFLE ANS82,<
SETZM WANT8.## ;DEFAULT TO ANS-74
TXNE AC10,SW.A82 ;DO WE WANT ANS-8x?
SETOM WANT8. ;YES
>
IFG ANS82,<
SETOM WANT8.## ;DEFAULT TO ANS-8x
TXNE AC10,SW.A74 ;DO WE WANT ANS-74?
SETZM WANT8. ;YES
>
HRRZS AC10 ;ONLY FEATURE TESTS WE CARE ABOUT
HRRZ AC3,LIBSW. ;GET OTS ASSEMBLY-TIME SWITCHES
CAME AC10,AC3 ;THE SAME?
OUTSTR [ASCIZ /%Compiler-OTS assembly switches mismatched.
/]
HLRZ AC10,COBVR.## ;GET COMPILER VERSION NUMBER
HLRZ AC3,LIBVR. ;GET OTS VERSION NUMBER
TRZ AC10,700000 ;GET RID OF CUSTOMER BITS
TRZ AC3,700000 ;...
CAMGE AC3,AC10 ;OTS THE SAME OR NEWER?
OUTSTR [ASCIZ /%Compiler-OTS version number mismatch.
/]
IFE TOPS20,<
MOVE AC10,[%CNVER] ;CONFIG TABLE
GETTAB AC10,
SETZ AC10, ;MUST BE VERY OLD
LDB AC10,[POINT 5,AC10,23] ;MONITOR VERSION NO.
CAIGE AC10,7 ;TEST FOR 7.00 SERIES MONITOR
JRST [OUTSTR [ASCIZ /?COBOL requires 7.01 or later.
/]
EXIT]
>
IFE TOPS20,<
HRROI AC1,.GTPRG ;MONITOR TABLE FOR PROGRAM NAME
GETTAB AC1,
MOVE AC1,RN.NAM ;USE PROGRAM NAME INSTEAD
>
IFN TOPS20,<
GETNM% ;GET PROGRAM NAME
>
MOVEM AC1,DF.PRG## ;SAVE AS DEFAULT FILE NAME
IFN TOPS20,<
SETZM DF.NAM## ;CREATE ASCIZ DEFAULT FILE NAME
SETZM DF.NAM+1
SKIPN AC2,AC1 ;GIVE UP IF ZERO
JRST RESET4
MOVE AC3,[POINT 7,DF.NAM]
RESET3: SETZ AC1,
LSHC AC1,6 ;GET NEXT CHAR
ADDI AC1,40 ;CONVERT TO ASCII
IDPB AC1,AC3
JUMPN AC2,RESET3
RESET4:>
IFN DBMS,<
MOVE AC1,[JRST FUNCT.##] ; put FUNCT. entry vector
MOVEM AC1,@[.JBBLT.+2] ; where DBCS can get at it
> ; end IFN DBMS
JRST 1(AC14) ;RETURN
;HERE TO CHAIN FILE-TABLES OF ALL SUBPROGRAMS TOGETHER
;POINTERS ARE AS FOLLOWS
;AC14/ ADR OF SP1 ;ADR OF ADR OF "MAIN" PROGRAM
;THE FOLLOWING ARE THE SAME FOR ALL SUBPROGRAMS
;SP1+1/ LST,,FILES. ;FILES. HAS ADR OF FIRST FILE-TABLE
;LST/ SP2 ;ADR OF SUBPROGRAMS CALLED BY SP1
;LST+1/ SP4 ; .
;LST+N/ 0 ;TERMINATES WITH A ZERO
RSTLNK: MOVEI AC3,AC3 ;THWART THE FIRST LINK
HRR AC1,(AC14) ;ADDRESS OF "MAIN" PRG + 1
HRL AC2,1(AC1) ;SETUP THE
HRRI AC2,FILES. ; FIXED
HRRZI AC4,FILES. ; PARAMETERS
BLT AC2,FIXNUM-1(AC4); %FILES THRU %PR
SETZM OVRFN. ;CLEAR THE OVR FILE PTR TO START
RSTL10: HRRZ AC5,(AC1) ;[346] CHECK TO SEE IF THIS SUBROUTINE
JUMPN AC5,RSTLNX ;[471] IS IN A LINK-10 OVERLAY AREA.
; ((AC1)) = SKIPA 0,0 ==> IT ISN'T
; ((AC1)) = JSP 1,MUMBLE ==> IT IS.
MOVE AC1,1(AC1) ;ADDRESS OF [LIST ,, FILES.]
HLRZ AC2,AC1 ;ADR OF LIST OF CALLED SUBPROGRAMS
SKIPGE AC4,(AC1) ;HAVE WE BEEN HERE BEFORE?
POPJ PP, ;YES, -1 IN LEFT HALF
MOVEI AC10,%OVRFN(AC1) ;[453] GET OVRFN ADDR
MOVE AC10,(AC10) ;[453] GET OVR FILE NAME
JUMPE AC10,RSTL13 ;[453] JUMP IF NO OVR FILE
SKIPE OVRFN. ;[453] ALREADY SEEN ONE?
JRST RSOVE1 ;[453] YES--ERROR
MOVEM AC10,OVRFN. ;[453] SAVE OVR FILE NAME
RSTL13: JUMPE AC4,RSTL12 ;[453] JUMP IF SUBPRG HAS NO FILE-TABLES
SKIPN FILES. ;HAS FILES. BEEN SETUP YET?
HRRM AC4,FILES. ;NO - SO DOIT
HRRM AC4,(AC3) ;LINK THIS FILE-TABLE GROUP TO LAST GROUP
RSTL11: HRRZI AC3,F.RNFT(AC4) ;GET ADR OF LINK TO NEXT TABLE
HRRZ AC4,(AC3) ;GET THE LINK TO NEXT TABLE
JUMPN AC4,RSTL11 ;LOOP IF NOT THE LAST TABLE
RSTL12: HRROS (AC1) ;MARK THIS FILE-TABLE GROUP DONE
RSTL20: SKIPN AC1,(AC2) ;ANY SUBPRGMS?
POPJ PP, ;NO -- BACK TO THE LAST SUBPRG OR EXIT
PUSH PP,AC2 ;SAVE POINTER TO SUBPROGRAM LIST
PUSHJ PP,RSTL10 ;GO LINK THE FILE-TABLES
POP PP,AC2 ;RETREIVE LIST POINTER
SKIPE 1(AC2) ;ANY MORE SUBPRGMS?
AOJA AC2,RSTL20 ;INCREMENT POINTER AND TRY AGAIN
RSTLNX: POPJ PP, ;[312] NO--DONE.
RSOVE1: OUTSTR [ASCIZ /?Only one module in a COBOL run-unit may have segmentation.
/] ;[453]
JRST KILL ;[453]
;ASSIGN THE BUFFER AREA. ***POPJ***
RSTAB.: PUSHJ PP,GCHAN ;FIND A FREE CHANNEL
PUSHJ PP,SETC1. ; ASSIGN TO IO UUOS
SETOM FS.IF ;IDX FILE
SETZM TEMP.1 ;ZERO THE ERROR COUNT
SETZM SHRDX. ;[556] CLEAR SHARED ISAM BUF AREA FLAG
HRRZ AC16,FILES. ;FIRST FILE TABLE
JUMPE AC16,RET.1 ;THERE ARE NO FILES
RSTIFI: SETZM TEMP. ;MAX SIZE OF BUF AREA
RSTIF1: LDB AC5,[POINT 4,UFRST.,12] ; GET CHAN FROM UUO
DPB AC5,DTCN. ;SAVE IT
MOVE FLG,F.WFLG(I16) ;GET THE FLAGS
TXNE FLG,B%RER!B%RRC ;RERUNING?
SETOM TEMP.2 ;YES, REMEMBER TO TURN OFF CHAN 17
HRLOI AC15,4077 ;[316] #OF DEVICES,,LOC OF FIRST ONE
AND AC15,F.WDNM(I16) ;
TXZE AC15,B%BLA ;IS BUFFER LOCATION ASSIGNED?
JRST RSTNFL ; [377A] YES-NEXT FILE
LDB AC1,F.BRMS ; GET RMS FLAG BIT
JUMPE AC1,RSTIF2 ; JUMP IF NOT AN RMS FILE
SETOM RMFLG.## ;SET FLAG SAYING RMS IS NEEDED
MOVX AC15,B%BLA ; NOTE WE ARE DONE
IORM AC15,F.WDNM(I16) ; WITH THIS FILE TABLE
JRST RSTNFL ; AND GET NEXT FILE
RSTIF2: MOVEM AC15,AC13 ;
TLC AC13,777777 ;MAKE
AOBJP AC13, .+1 ;KIND OF
HRR AC13,AC15 ;AN IOWD
MOVEM AC13,D.ICD(I16) ;%-<#OF DEVS>,,LOC OF FIRST DEVNAM
RSTDEV: MOVE AC3,(AC13) ;SIXBIT /DEVICE NAME/
IFN SIRUS,<MOVE AC1,AC3 ; [403] KEEP DEVICE >
DEVCHR AC3, ;DEVCHR UUO
TXNN AC3,DV.CDR!DV.LPT!DV.PTP!DV.PTR!DV.TTY ;SKIP IF A LPT,TTY,PTP,PTR,CDP, OR CDR
JRST RSTDE0 ;
TXC AC3,DV.DSK!DV.CDR ;[506] IF A DSK AND A CDR ...
TXCE AC3,DV.DSK!DV.CDR ;[506] THEN IT'S DEVICE NUL:
JRST RSTDV1 ;[506] NOT NUL:, CONTINUE
TXZ AC3,DV.MTA!DV.TTY ;[506] NUL:, SO NOT MTA OR TTY
LDB AC12,[POINT 3,FLG,14] ;[506] CORE DATA MODE
DPB AC12,[POINT 3,FLG,2] ;[506] MAKE DEV DATA MODE SAME
MOVEM FLG,F.WFLG(I16) ;[506] SAVE IT
JRST RSTDE0 ;[506] CONTINUE
RSTDV1: TLO FLG,DDMASC ;FORCE ASCII MODE
TLZ FLG,DDMBIN!DDMSIX!DDMEBC ; FOR THE ABOVE DEVICES
MOVEM FLG,F.WFLG(I16) ;
RSTDE0: JUMPN AC3,RSTDE2 ;
IFN SIRUS,<
MOVE AC3,(AC13) ; [403] GET DEVICE NAME
CAME AC3,SIRDEV ; [403] IS IT SIRUS DEVICE?
JRST RSTDE1 ; [403] NO-ERROR
MOVSI AC3,'NUL' ; [403] YES-MAKE IT NULL DEVICE
JRST RSTDEV+1 ; [403] TRY AGAIN
>; END OF IFN SIRUS
RSTDE1: MOVE AC2,[BYTE(5)25,4,20,13,23,15,14];"NOT A DEVICE OR
PUSHJ PP,MSOUT. ;NOT AVAILABLE TO THIS JOB
AOS TEMP.1 ;COUNT THE ERRORS
JRST RSTLOO ;
RSTDE2: SETZM UOBLK. ;[411] MAKE SURE WE DONT GET ILLEGAL MODE IF ASCII DEV
MOVE AC12,.JBFF
SKIPN SHRDX. ;[556] IF ISAM SHARED BUF, D.BL ALREADY SET
HRLM AC12,D.BL(I16) ;SET BUFFER LOCATION
IFN SIRUS,< MOVE AC12,AC1 ; [403] GET BACK DEVICE >
IFE SIRUS,< MOVE AC12,(AC13) ;SIXBIT /DEVNAM/>
MOVEM AC12,UOBLK.+1 ;FOR THE INIT BLOCK
HRLZI AC12,D.OBH(I16) ;LOC OF OBUF HDR
TLNE FLG,IOFIL ;[622] SKIP IF NOT IO
HRRI AC12,D.IBH(I16) ;LOC OF IBUF HDR
MOVEM AC12,UOBLK.+2 ;INIT BLOCK
MOVEI AC1,.IODMP ;DUMP MODE
TLNE FLG,IDXFIL ;INDEX-FILE?
HRRZM AC1,UOBLK. ;YES
IFN TOPS20,<
TLNE FLG,IDXFIL ;ISAM FILE?
JRST RSTD21 ;YES
>
XCT UOPEN. ;********************
JRST RSTDE1 ;INIT FAILED, ERROR RETURN
RSTD21: PUSH PP,.JBFF ;
TLNE FLG,IDXFIL ;
JRST RSTIDX ;SETUP FOR AN INDEX FILE
SUBTTL LABELED TAPE RESET CODE
TXNN AC3,DV.MTA ; SKIP IF MTA
JRST MTOXX0 ; ELSE GO ON
MOVE AC12,AC3 ;SAVE AC3, CLOBERED LATER
IFN TOPS20,<
;THIS IS STUFF FOR VERSION 4 OF TOPS20, TO TAKE
;CARE OF TAPE HANDLING BY MOUNTR , INCLUDING LABEL PROCESSING.
HLLZ AC6,D.F1(I16) ; GET SECOND FLAG WORD
; NOW CHECK FOR MONITOR LABEL PROCESSING
PUSHJ PP,MTALAB ; GET MTA LABEL INFO
JRST MTOXXY ; NON SYS-LABELING, CONT
LDB AC2,F.BLBT ; GET LABEL TYPE FROM FILTAB
SOSE AC2 ; SKIP IF NO LABELING, TYP=1 IF NO LABELING
TLOA AC6,MSTNDR ;INDICATE MONITOR IS LABELING
TLOA AC6,MTNOLB ;SET MOUNTR WITH NO LABELING FLAG
TXZ AC6,B%STL ;CLEAR LABEL BITS IN D.F1
HLLM AC6,D.F1(I16) ;RESET IN FILTAB
> ;END IFN TOPS20
JRST MTOXXY ; CONT WITH OTHER CHECKS
; GTDFLT ROUTINE TO GET DEFAULT DATA MODE SETTING
;
; RETURNS AC3=DEFAULT MODE
; USES AC1-AC3
;
GTDFLT:
IFN TOPS20,<
SETO AC1, ; AC1=-1, THIS JOB
HRROI AC2,3 ; DATA MODE AT AC3
MOVEI AC3,.JIDM ; START BLOCK AT THE DEFAULT DATA MODE WORD
GETJI% ; GET THE DATA MODE
JRST KILL. ; ASSUME IT WORKS, SHOULD ALWAYS
POPJ PP, ; RET
>; END IFN TOPS20
IFE TOPS20,<
MOVE AC3,[2,,1] ; 2 ARGS START AT AC1
MOVEI AC1,.TFMOD ; DATA MOD FUNCTION
MOVE AC2,UOBLK.+1 ; DEVICE NAME
TAPOP. AC3, ; GET DEFAULT DEVICE DATA MODE
JRST [MOVE AC2,AC3 ; ERROR, PUT ERROR CODE INTO AC2
JRST OMTA93 ] ; AND GIVE ERROR
POPJ PP, ; OK, RET
>; END IFE TOPS20
IFN TOPS20,<
; GETJFN ROUTINE TO GET JFN FROM PA1050 USING COMPT. UUO
;
; ARGS AC2=CHAN NUMBER
;
; RETURNS NON-SKIP ERROR RETURN
; SKIP OK, AC1=JFN
;
; USES AC1,AC2
;
GETJFN: HRLZ AC2,AC2 ;GET CHAN NUM IN LEFT,AS ARG TO COMPT.
HRRI AC2,CMP.10 ;SET COMPT. FUNCTION NUM FOR CHAN TO JFN
MOVE AC1,[1,,2] ;INDICATE 1 ARG IN ADDR 2
SETZM CMPTER## ;ZERO OUT ERROR WORD
COMPT. AC1, ;GET JFN *************
SKIPA ;ERROR
JRST RET.2 ; OK, RETURN
MOVEM AC1,CMPTER ;SAVE ASIDE UUO ERROR CODE
POPJ PP, ; ERROR RETURN
>;END IFN TOPS20
; MTALAB A ROUTINE TO READ MTA LABEL INFO
;
; USES AC1-AC3, TEMP AREA (SIZE MTOSIZ+1) ON STACK
;
; RETURNS NON-SKIP IF LAB-BYPASS (NO MOUNTR CONTROL)
; SKIP IF LABELED, LABEL INFORMATION IS LOCATED
; AT TMP.BK
MTALAB:
IFN TOPS20,<
LDB AC2,UUOCHN ;GET CHANNEL NUM
PUSHJ PP,GETJFN ; GET JFN IN AC1
JRST [OUTSTR [ASCIZ/RESET get JFN /] ;ERROR, ISSUE MESSAGE
JRST OCPERR ] ;MORE MESS AND KILL
;GET AND CLEAR A TEMP TABLE AREA FOR MTOPR
;PUT TABLE LENGTH IN FIRST WORD,AS MTOPR WANTS
HRRM AC1,D.JFN(I16) ;STORE JFN
MOVE AC3,AC1 ; SAVE JFN IN CASE OF OPEN ERROR
GTSTS% ; GET FILE STATUS
HRR AC2,AC3 ; SAV JFN HERE
PUSH PP,AC2 ; SAV STATUS,,JFN
JUMPL AC2,MTLAB1 ; JUMP IF ALREADY OPEN
MOVE AC2,[440000,,OF%RD] ;INDICATE SIMPLE 36 BIT BYTE,INPUT
OPENF% ;OPEN THE JFN***************
ERCAL OPNFER ;ERROR?, THEN GO CHECK IT (RETURNS IF OK)
MTLAB1: MOVEI AC3,TMP.BK ; INDICATE THAT THE TEMP AREA WILL BE TMP.BK
MOVEI AC2,1(AC3) ;GET TEMP TAB ADDR
SETZM (AC3) ;ZERO FIRST WORD
HRLI AC2,-1(AC2) ;MAKE BLT PTR
BLT AC2,MTOSIZ-1(AC3) ;ZERO TEMP AREA,TO MAKE SURE NO INFO FROM
;MTOPR WILL BE STUCK IN A BAD PLACE
MOVEI AC2,MTOSIZ ;GET MTOPR SIZE
MOVEM AC2,(AC3) ;INITIALIZE TAB LENGTH
MOVEI AC2,.MORLI ;SET MTOPR FUNCTION CODE FOR READING LABELS
MTOPR% ;GET LABEL INFO ***************
ERJMP MTOPER ;ERROR, CHECK FOR ILLEGAL FUNCTION
;INDICATING MOUNTR NOT AROUND
MOVE AC5,TMP.BK+LABFOR ; GET LABEL FORMAT CHAR
PUSHJ PP,SETFMT ; SET LABEL FORMAT BITS
MOVE AC2,TMP.BK+LABTYP ; GET LABEL TYPE
DPB AC2,F.BLBT ; SET LABEL TYPE INTO FILTAB
CAIE AC2,.LTEBC ; IS LABEL TYPE EBCDIC?
JRST MTLAB2 ; NO, CONT
; IF EBCDIC LABELS, SET NO TRANSLATE
HRRZ AC1,(PP) ; GET JFN FROM SAVED POSITION ON STACK
MOVEI AC2,.MONTR ; INDICATE NO TRANSLATE
SETO AC3, ; TO BE SET
MTOPR% ; DO IT
ERJMP MTOERR ; ERROR, ISSUE MESSAGE AND QUIT
MTLAB2: POP PP,AC3 ; RESTORE INITIAL FILE STATUS
JUMPL AC3,RET.2 ; RETURN IF OPEN AT START
HRRZ AC1,AC3 ; GET JFN
TXO AC1,CO%NRJ ; DON'T RELEASE IT
CLOSF% ; CLOSE THE FILE
JRST CLSERR ; ERROR, MESSAGE AND QUIT
JRST RET.2 ; OK, LABELING OF SOME KIND, GIVE SKIP RETURN
; ERROR ON GET-LABEL-INFO MTOPR, CHECK FOR ILLEGAL OPERATION,
; INDICATING NO MOUNTR, OR LABELS-BYPASS
MTOPER: POP PP,AC3 ; RESTORE GTSTS CODE
MOVEI AC1,.FHSLF ;INDICATE CURRENT PROCESS
GETER% ;GET LAST ERROR NUM IN AC2 (RT HALF)
CAME AC2,[.FHSLF,,MTOX1] ; AN INVALID FUNCTION ERROR (VER. 4)?
JRST MTOERR ; NO, MTOPR ERROR, ISSUE MESSAGE AND QUIT
; YES,THEN THIS INDICATES THAT NO MOUNTR
JUMPL AC3,RET.1 ; RETURN, NON-SKIP IF FILE WAS OPEN
HRRZ AC1,AC3 ; ELSE,GET JFN
TXO AC1,CO%NRJ ; DON'T RELEASE IT
CLOSF% ; CLOSE THE FILE
JRST CLSERR ; ERROR, MESSAGE AND QUIT
POPJ PP, ; GIVE NON-SKIP RETURN
>;END IFN TOPS20
IFE TOPS20,<
; FOR TOPS10 NEED TO DO A COUPLE OF UUOS TO GET INFO
; IF PULSAR LABEL PROCESSOR IS UP AND WE'RE NOT BYPASSING
; LABELS THEN LET PULSAR DO THE LABELING. IF BYPASS LABELS
; IS ON THEN LIBOL WILL DO LABELING AS ALWAYS.
SKIPN AUTOLB ; DO WE HAVE AUTO LABEL PROCESSING?
POPJ PP, ; NO, GIVE NO-LABELS RETURN
; YES
MOVEI AC3,TMP.BK ; INDICATE THAT THE TEMP AREA WILL BE TMP.BK
MOVEI AC2,1(AC3) ;GET TEMP TAB ADDR
SETZM (AC3) ;ZERO FIRST WORD
HRLI AC2,-1(AC2) ;MAKE BLT PTR
BLT AC2,MTOSIZ-1(AC3) ;ZERO TEMP AREA
HRLZI AC3,2 ; LENGTH ,, ADDRESS
MOVEI AC0,.TFLBL ; FUNCT - LABEL PROCESSING
MOVE AC1,UOBLK.+1 ; SIXBIT /DEVICE NAME/
MOVEM AC1,TMP.BK+1 ; ALSO SET IN ARG BLK FOR LABEL INFO
TAPOP. AC3, ; GET TYPE OF LABEL PROCESSING
JRST OMTA96 ; OOPS - COMPLAIN
CAIN AC3,.TFLNV ; WAS THAT "USER EOV , UNLABELED"?
MOVEI AC3,.TFLNL ; YES, INDICATE UNLABELED
DPB AC3,F.BLBT ; SET LABEL TYPE IN FILTAB
CAIN AC3,.TFLBP ; LABEL-BYPASS?
POPJ PP, ; YES,GIVE NON-LABELING RETURN IF BYPASS
; NOW GET OTHER LABEL INFO
MOVE AC2,[XWD .TPLEN,TMP.BK] ; INDICATE SIZE AND POSITION OF ARGBLK
MOVEI AC1,.TFLPR ; INDICATE GET LABEL INFORMATION
MOVEM AC1,TMP.BK ;
TAPOP. AC2, ; GET LABEL INFORMATION
JRST LBTPER ; ERROR, COMPLAIN
MOVEM AC3,TMP.BK+LABTYP ; SET LABEL TYPE
MOVE AC1,TMP.BK+.TPREC ; GET FORMAT AND FORMS CONTROL INFO
HLRZM AC1,TMP.BK+LABFMS ; RESET FORMS CONTROL WORD
HRRZM AC1,TMP.BK+LABFOR ; AND FORMAT WORD
TLZ AC1,-1 ; CLEAR LEFT HALF
MOVEI AC2,1 ; SET A BIT
SOJLE AC1,.+2 ; IF "F" (OR DEFAULT) USE 1
LSH AC2,(AC1) ; SHIFT BIT TO INDICATE FORMAT
DPB AC2,F.BFMT ; SET LABEL FORMAT BITS
JRST RET.2 ; GIVE LABELED RETURN
; HERE IF LABELED TAPOP. ERROR
; ASSUMES THAT AC2 HAS ERROR CODE
LBTPER: JUMPN AC2,OMTA96 ; GO GIVE ERROR IF REAL ONE
; HERE FOR UNIMPLEMENTED FEATURE ERROR
MOVEI AC3,.TFLNL ; SET UNLABELED
DPB AC3,F.BLBT ; SET LABEL TYPE IN FILTAB
JRST RET.2 ; GIVE LABELED RETURN
>;END IFE TOPS20
; TM03AS ROUTINE TO CHECK FOR ANSI-ASCI SUPPORT ON TAPE
;
; IF STD-ASCII NOT SUPPORTED, INDASC FLAG SET TO
; INDICATE THAT STD-ASCII MUST BE DONE WITH INDUSTRY
; COMPATIBLE MODE TAPE SETTING
;
; RETURNS CALL +1 ALWAYS
;
TM03AS:
IFN TOPS20,<
PUSHJ PP,MTASTS ; GET MTA STATUS INTO TMP.BK
JRST TM03AY ; ERROR, ASSUME NO STD-ASCII SUPPORT
MOVE AC2,TMP.BK+.MODDM ; GET DATA MODES WORD
TXNE AC2,SJ%CMA ; IS STD-ASCII SUPPORTED?
TM03X: POPJ PP, ; YES,RETURN NOW
>;END IFN TOPS20
IFE TOPS20,<
HRLZI AC3,2 ; LENGTH ,, ADDR
MOVEI AC0,.TFKTP ; FUNCTION
MOVE AC1,UOBLK.+1 ; GET DEVICE NAME
TAPOP. AC3, ; GET CONTROLER TYPE
JRST TM03AY ; ERROR, ASSUME NOT SUPPORTED
CAIE AC3,.TFKTX ; TX01 CONTROLLER (TU70/TU71)?
CAIN AC3,.TFKD2 ; SKIP IF DX20/TX02 CONTROLLER (OK TOO)
POPJ PP, ; YES, RETURN, STDASC IS SUPPORTED
; NO, NOT SUPPORTED FOR SURE
>; END IFE TOPS20
; NOT SUPPORTED, SET INDASC FLAG, INDUSTRY-COMPT. NEEDED
TM03AY: MOVEI AC2,INDASC ; SET STANDARD ASCII FLAG
IORM AC2,D.RFLG(I16)
POPJ PP, ; RETURN NOW
MTOXXY:
; CHECK TO SEE IF AN ASCII TAPE IS TO BE WRITTEN TO
; A DRIVE WITH STANDARD-ASCII DATA MODE SET. IFSO, SET STD-ASCII
; RECORDING MODE.
HRRZ AC1,D.RFLG(I16) ; GET STANDARD ASCII FLAG
TRNE AC1,SASCII ; IS IT?
JRST MTALB0 ; YES, ALL OK
; NO ATTRIBUTES SET, HOW ABOUT DEFAULT DATA MODE?
MTLB0D: PUSHJ PP,GTDFLT ; GET DEFAULT DATA MODE IN AC3
IFN TOPS20,<
CAIE AC3,.SJDMA ; IS DATA MODE ANSI-ASCII?
>
IFE TOPS20,<
CAIE AC3,.TFM7B ; IS DATA MODE ANSI-ASCII?
>
JRST MTLB0F ; NO, SKIP THIS
MTLB0E: JUMPGE FLG,MTLB0A ; JUMP IF NOT AN ASCII DEVICE MODE
MTLB0C: MOVEI AC3,SASCII ; SET STD-ASCII BIT
IORM AC3,D.RFLG(I16) ; THIS WILL INDICATE THAT DEFAULT
; ADVANCING WILL BE 0 ADVANCING
; CHECK FOR BLK-FTR = 0 CASE, HERE IF STD-ASCII
MTALB0:
IFN TOPS20,<
TLNN AC6,MSTNDR ; WAS THAT A LABELED TAPE?
> ; TOPS20 DOES PROPER MAP TO 7-BIT
; NO NEED TO CHECK (CAN'T SET HARDWARE MODE
; IF WE WANTED TO )
PUSHJ PP,TM03AS ; NO, CHECK FOR TM03: (MAYBE SET INDASC BIT)
MTAB0A: LDB AC5,F.BBKF ; GET BLOCKING FACTOR
JUMPN AC5,MTOXXX ; CONTINUE IF BLK-FTR NOT 0
MOVEI AC2,1 ; ELSE BLK-FTR DEFAULTS TO 1
MOVE AC3,AC12 ; GET DEVICE CHAR AGAIN
DPB AC2,F.BBKF ;
PUSHJ PP,RSTBPB ; CALC BUFFS PER BLOCK
JRST MTOXXX ; CONT
; HERE IF STD-ASCI TAP FORMAT, BUT NOT ASCII RECORDING MODE
; IF RECORDING MODE IS DEFAULT, THEN SET TO ASCII
; IN THOSE CASES THAT MAKE SENSE
MTLB0A: LDB AC3,F.BDRM ; GET DEFAULT DDM MODE FLAG
JUMPE AC3,MTOXXX ; IS DEV-DATA-MODE DEFAULT?
; NO, JUMP ASSUMING HE KNOWS WHAT HES DOING
TLCN FLG,DDMSIX ; SKIP IF MODE SIXBIT
TLCA FLG,DDMSIX ; NO, CLEAR IT , ERROR CONDITION, SKIP
JRST MTLB0B ; YES, ITS CLEARED, GO SET ASCII
; HERE IF NOT SIXBIT DEFAULT RECORDING MODE, ASSUMES ITS AN ERROR
; CONDITION TO TRY WRITING OTHER DATA MODES ON STD-ASCII TAPE
PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /Tape data mode mismatchs file default recording mode./]
MOVE AC2,[BYTE (5) 10,31,20,2]
PUSHJ PP,MSOUT. ;DOESN'T RETURN
MTLB0B: TLO FLG,DDMASC ; SET ASCII RECORDING MODE
MOVEM FLG,F.WFLG(I16) ; AND UPDATE FLAG WORD
JRST MTLB0C ; AND GO BACK AS IF ASCII RECORDING MODE SET
MTLB0F:
; HERE IF NOT STD-ASCII HARD MODE
TLNN AC6,MSTNDR ; WAS THAT A LABELED TAPE?
JRST MTOXXX ; NO, CONT
IFE TOPS20,<
; IF ANSI LABELED TAPE WITH ASCII DDM, MAKE
; SURE HE WILL WRITE COMPATIBLE TAPE MODE (ANSI-ASC OR IND-CMP)
JUMPGE FLG,MTOXXX ; CONT IF NOT ASCII RECORDING MODE
PUSHJ PP,MTALAB ; GET LABEL INFO (SETS AC3)
JRST MTOXXX ; UNLABELED,CONT
LDB AC3,F.BLBT ; GET LABEL TYPE FROM FILTAB
CAIE AC3,.TFLAL ; IS THE LABEL TYPE ANSI
CAIN AC3,.TFLAU ; OR ANSI WITH USER LABELS?
JRST MTALB0 ; YES, CHECK BLOCKING AND HARD MODE
JRST MTOXXX ; NO, CONT
>; END IFE TOPS20
IFN TOPS20,<
; IF ASCII WITH F OR D ATTRIBUTE
; THEN CHANGE UNBLOCKED TO BLOCK 1
JUMPGE FLG,MTOXXX ; CONT IF NOT ASCII
LDB AC1,F.BLBT ; GET LABEL TYPE
CAIE AC1,.LTEBC ; SKIP IF EBCDIC LABEL
PUSHJ PP,GETATB ; GET FILE FORMAT ATTRIBUTES
JRST MTOXXX ; NONE SET, DO OTHER CHECK
CAIE AC5,"F" ; IS FORMAT "F"?
CAIN AC5,"D" ; IS FORMAT "D"?
JRST MTAB0A ; YES, CHECK BLOCKING
JRST MTOXXX ; NO, CONT
>; END IFN TOPS20
MTOXXX: MOVE AC3,AC12 ; RESTORE AC3
MTOXX0:
SUBTTL MORE RESET
TXNN AC3,DV.MTA ;SKIP IF A MTA
TLNE FLG,RANFIL+IOFIL ;[622] SKIP IF NOT RANDOM OR IO
JRST RSTDE4 ;SETUP FOR NON-STD OR DUMP MODE BUFFERS
RSTDE7: LDB AC6,F.BNAB ;NUMBER OF BUFFERS
SKIPN AC6 ;IF ZERO
MOVEI AC6,DFLTBF ;USE DEFAULT
XCT UOBUF. ;ALLOCATE **************
TLNE FLG,IOFIL ;[622] THE
XCT UIBUF. ;BUFFERS **************
HLLZ AC6,D.F1(I16) ; GET SECOND FLAG WORD
; CALC THE BUFFS/BLOCK FOR BLOCKED CASES
LDB AC5,F.BBKF ; GET BLOCKING FACTOR
JUMPE AC5,RSTDE5 ; GO ON IF UNBLOCKED
PUSHJ PP,RSTBPB ; CALC BUFFS PER BLOCK
RSTDE5:
HLRZ AC12,D.BL(I16) ;CALCULATE
SUB AC12,.JBFF ;THE SIZE
POP PP,.JBFF ;
MOVNS AC12 ;OF THE BUFFER AREA
IFN TOPS20,<
HRLZM AC12,D.FBS(I16) ;SAVE IT FOR NATIVE I/O
>
RSTDE3: CAML AC12,TEMP.
MOVEM AC12,TEMP. ;SAVE SIZE OF LARGER
;LOOP AGAIN
RSTLOO:
TLNN FLG,IDXFIL
AOBJN AC13,RSTDEV ;JUMP IF MORE DEV/FILTAB
RSTLO1: MOVX AC15,B%BLA ;[316];NOTE WE ARE DONE
IORM AC15,F.WDNM(I16);WITH THIS FILE TABLE
HLRZ AC1,F.LSBA(I16) ;SEE IF ANY SHARING OF BUFFERS
JUMPE AC1,RSTNFL ;GET THE NEXT FILE TABLE
MOVEM AC1,AC16 ;
JRST RSTIF1 ;SHARES THE SAME BUFFER AREA
RSTNFL: MOVE AC12,TEMP. ;INCREASE .JBFF BY
ADDM AC12,.JBFF ;THE BUFFER AREA SIZE
SETZM SHRDX. ;[556] CLEAR ISAM SHARED BUF FLAG
HRRZ AC16,F.RNFT(I16);LOCATE THE NEXT FILE TABLE
JUMPN AC16,RSTIFI ;AND JUMP IF THERE IS ONE.
SKIPE TEMP.1 ;ANY ERRORS ?
JRST KILL ;YES
XCT URELE. ;RELEASE THE CHANNEL
;GRAB SPACE FOR THE AUX BLOCK
SKIPE MXBUF ;EXIT IF NO INDEXED FILES
SKIPE KEYCV. ;SKIP IF RESET UUO
JRST RSTXIT ;EXIT - ITS A SORT CALL
MOVE AC0,MXBUF ;SIZE OF AUX BLOCK
MOVE AC1,.JBFF ;
HRRZM AC1,AUXBUF ;LOCATION OF AUX BLK
PUSHJ PP,GETSPC ;
JRST GETSPK ;ERROR RETURN
;SPACE FOR DATA-RECORD-TABLE FOR SPLITTING BLOCKS
MOVE AC0,MXBF ;MAX-BLOCKING FACTOR OF ALL IDXFIL'S
ADDI AC0,1 ;TERMINATOR
MOVE AC1,.JBFF ;
HRRZM AC1,DRTAB ;
PUSHJ PP,GETSPC ;
JRST GETSPK ;ERROR RETURN
;SPACE FOR INDEX ENTRY WHEN SPLITTING TOP INDEX BLOCK
MOVE AC0,MXIE ;SIZE OF LARGEST INDEX ENTRY
MOVE AC1,.JBFF ;
HRRZM AC1,IESAVE ;LOC OF SAVE AREA
PUSHJ PP,GETSPC ;
JRST GETSPK
RSTXIT: LDB AC2,[POINT 4,UOPEN.,12] ;FREE THE CHANNEL
PUSHJ PP,FRECH2 ; AND POPJ
HRLZI AC0,577774 ;[342]TURN OFF CHAN 1
SKIPN TEMP.2 ;ANY RERUNS?
POPJ PP, ;NO
ANDM AC0,OPNCH. ;YES, DOIT
SETOM RRFLG.## ;REMEMBER
POPJ PP,
; CALCULATE THE NUMBER OF BUFFERS PER LOGICAL BLOCK
RSTBPB: PUSH PP,AC13 ; SAVE AC13,OPNWPB ASSUMES DEVICE CHAR IN AC13
MOVE AC13,AC3 ; GET DEVICE CHAR
PUSHJ PP,OPNWPB ; AC10= WORDS PER LOGICAL BLOCK
PUSH PP,AC10 ; SAVE AC10 FOR CALLER
MOVEI AC0,DSKBSZ ;DSK BUFFER SIZE
TLNE FLG,IOFIL!RANFIL!IDXFIL ;[622] SKIP IF NOT RANDOM OR IO
JRST RSTBP3 ;
TXNN AC13,DV.MTA ;SKIP IF A MTA
JRST RSTBP1 ;JUMP, NOT A MTA
JUMPE AC5,RSTBP1 ;JUMP IF BLK-FTR IS ZERO (AC5)
MOVEI AC10,1 ;ONE BUFFER PER LOGICAL BLOCK
JRST RSTBP2 ;
RSTBP1: HRRZ AC11,D.OBH(I16) ; RESET ASSUMES USE OF AT LEAST OUTBUF
HLRZ AC0,(AC11) ;BUFFER SIZE + 1 IN WORDS
SUBI AC0,1 ;SIZE
RSTBP3: IDIV AC10,AC0 ;/BUF-SIZE
SKIPE AC10+1 ;ROUND UP
ADDI AC10,1 ;AC10=BUFFERS PER LOGICAL BLOCK
;BL; 2 LINES INSERTED AT RSTBP3+3 TO FIX ISAM/RANDOM SHARED BUFFR BUG
TLNE FLG,IDXFIL ;ISAM FILE?
SKIPN PAGBUF(I12) ;YES, & PAGE I/O TOO?
JRST RSTBP2 ; NO
ADDI AC10,3 ; YES, ADD 3 SECTORS
LSH AC10,-2 ; AND
LSH AC10,2 ; ROUND OFF
RSTBP2: MOVEM AC10,D.BPL(I16) ;BUFBLK
POP PP,AC10 ; RESTORE AC10, WDS/LOG-BLK
POP PP,AC13 ; RESTORE AC13
POPJ PP, ; ALL DONE RETURN
;SETUP FOR NONSTD BUFFERS OR DUMP MODE
RSTDE4: LDB AC5,F.BBKF ;BLOCKING FACTOR
JUMPN AC5,RSTD40 ; IF BLK-FTR = 0
TLNE FLG,DDMEBC ; AND DEVICE DATA MODE IS EBCDIC
TXNN AC3,DV.MTA ; AND DEVICE IS A MTA
JRST RSTD40 ;
MOVEI AC5,1 ; THEN BLK-FTR DEFAULTS TO 1
DPB AC5,F.BBKF ;
RSTD40: JUMPE AC5,RSTDE7 ;JUMP IF BLOCKING FACTOR IS 0
PUSHJ PP,RSTBPB ; CALC BUFFS PER LOG-BLK,AC10=WDS PER LOG-BLK
TXNN AC3,DV.MTA ;SKIP IF A MTA
JRST RSTDE6 ;JUMP ITS NOT A MTA
CAIL AC10,MXTPRC ;SKIP IF LOG. BLK NOT TOO LARGE
JRST MXTPER ;JUMP IF TOO LONG
ADDI AC10,3 ; PLUS 3 FOR BOOKEEPING WORDS
HLLZ AC6,D.F1(I16) ;SECOND FLAG REG
TXNN AC6,B%STL ;SKIP IF STANDARD LABELS
JRST RSTD41 ;MTA W/NONSTD OR OMITTED LABELS
CAIGE AC10,^D16+4 ;SKIP IF RECORD IS GE THE LABEL RECORD
MOVEI AC10,^D16+4 ;ENSURE LABEL REC WILL FIT IN REC AREA
RSTD41: TLNN FLG,DDMEBC ;SKIP IF EBCDIC
JRST RSTDE8 ;ITS NOT
SKIPGE D.F1(I16) ; VARIABLE LENGTH EBCDIC?
ADDI AC10,1 ; YES - ADD IN ONE FOR BLOCK DESCRIPTOR WORD
RSTD42: TXNN AC6,B%STL ; LABELS STANDARD?
JRST RSTDE8 ;NO - MUST BE OMITTED
CAIGE AC10,^D20+4 ;
MOVEI AC10,^D20+4 ;LABEL RECORD IS THE LARGEST RECORD
RSTDE8: MOVEI AC1,-3(AC10) ;
HRRM AC1,D.LRS(I16) ;SAVE IT FOR OPNNSB
LDB AC12,F.BNAB ;NUMBER OF BUFFERS
SKIPN AC12 ; SKIP IF NOT ZERO RESERVED
MOVEI AC12,DFLTBF ; 0 MEANS DEFAULT NUMBER
IMULI AC10,(I12) ; NO, REC TIMES NUMBER OF BUFFERS
JRST RSTD11 ; OK, NOW GET MEM
RSTDE6: TXNN AC3,DV.DSK ;SKIP IF DEV IS A DSK
JRST RSTER0 ;COMPLAIN
TRZE AC10,DSKMSK ;ALLOCATE FULL DISK BLKS
ADDI AC10,DSKBSZ ;ROUND UP TO NEXT DISK BLK
ADDI AC10,13 ;3+8=13 FLAG WORDS REQD FOR RANDOM OR IO
RSTD11: MOVE AC0,AC10 ;SETUP AC0 FOR GETSPC
PUSHJ PP,GETSPC ;CLAIM THE BUFFER AREA
JRST GETSPK ;NO MORE CORE
JRST RSTDE5 ;RETURN
RSTER0: PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /Only DSK may be used for RANDOM, I-O or INDEX-SEQUENTIAL processing./]
RSTERR: MOVE AC2,[BYTE (5)10,31,20]
PUSHJ PP,MSOUT.
MXTPER: PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /Mag tape logical block size too large./]
MOVE AC2,[BYTE (5) 25,4,10,31,20] ;INDICATE WHICH FILE AND
;WHICH DEVICE HAS TROUBLE
PUSHJ PP,MSOUT. ;THEN QUIT
;SETUP FOR AN INDEX FILE
RSTIDX: ; IF THERE ARE ANY FILES THAT SHARE THE SAME BUFFER AREA
; THEN ALLOCATE THE SPACE FOR THE "SAVE" AREAS NOW.
; THE "SAVE" AREAS, ONE PER FILE, ARE LOCATED DIRECTLY
; BEFORE THE SHARED BUFFER AREA AND ARE POINTED TO BY D.IBL.
HLRZ AC12,F.LSBA(I16); [377A] GET LINK TO FILE TBL THAT SHARES
JUMPE AC12,RSTI05 ; [377A] [556] JUMP IF NONE
HRRZ AC6,D.IBL(I16) ; [377A] GET ADR OF "SAVE" AREA
JUMPN AC6,RSTI05 ; [377A] [556] JUMP IF ALREADY DONE
SETOM SHRDX. ;[556] SET SHARED ISAM BUF FLAG,INDICATING THAT
;[556] ALL FILES IN THIS SHARE CHAIN WILL HAVE
;[556] THEIR D.BL LOCATIONS SET BELOW AT RSTI04
MOVE AC12,I16 ; [377A] GET FIRST LINK
HLRZ AC4,D.BL(I16) ; [377A] ADR OF SBA (SHARED BUFFER AREA)
RSTI01: MOVEI AC0,ISMCLR+1 ; [377A] GET SIZE OF "SAVE" AREA
PUSHJ PP,GETSPC ; [377A] GET THE CORE SPACE
JRST GETSPK ; [377A] OOPS
HRRM AC4,D.IBL(AC12) ; [377A] SAVE ADR OF "SAVE" AREA
HRLZI AC6,ISMCLR+1 ; [377A] SIZE OF "SAVE" AREA
ADDM AC6,D.BL(I16) ; [377A] MOVE SBA TO OTHER SIDE OF "SAVE" AREA
MOVEI AC6,ISMCLR+1 ; [377A] SIZE OF "SAVE" AREA
ADDM AC6,(PP) ; [377A] UPDATE SAVED .JBFF
RSTI02: HLRZ AC12,F.LSBA(AC12);[377A] GET LINK TO NEXT FILE TBL
CAMN AC12,I16 ; [377A] HAVE WE CIRCLED THE CHAIN?
JRST RSTI03 ; [377A] YES - THEN DONE
LDB AC0,[POINT 3,F.WFLG(AC12),17]; [377A] GET ACCESS MODE
CAIE AC0,4 ; [377A] IS THIS AN ISAM FILE?
JRST RSTI02 ; [377A] NO - TRY NEXT LINK
HRRZ AC4,.JBFF ; [377A] GET ADR OF NEXT FREE LOC
JRST RSTI01 ; [377A] LOOP
;[556] NOW UPDATE BUF LOCATIONS FOR ALL THAT SHARE WITH THIS
;[556] INDEX FILE,SINCE ALLOCATION OF SAVE AREAS HAS MOVED IT
;[556] DOWN AT LEAST ONCE.
; [556] THIS CROCK UPDATES MORE THAN NECESSARY,SINCE THOSE IN
; [556] CHAIN FOLLOWING THE FIRST ISAM FILE WILL BE UPDATED
; [556] AT RSTDE2+2. THIS IS EASIEST WAY TO GET AT ALL
; [556] THAT MAY HAVE COME BEFORE THE FIRST ISAM FILE.
RSTI03: MOVE AC0,D.BL(I16) ;[556] GET NEW BUF LOC FOR ALL THIS SHARE CHAIN
RSTI04: HLRZ AC12,F.LSBA(AC12) ;[556] GET FILTAB OF NEXT FILE THAT SHARES
CAMN AC12,I16 ;[556] ALL WHO SHARE UPDATED?
JRST RSTI05 ;[556] YES,CONT.
HLLM AC0,D.BL(I12) ;[556] NO,UPDATE BUF LOC OF NEXT THAT SHARES
JRST RSTI04 ;[556] CONT. AROUND CHAIN
RSTI05: ;[556]
PUSHJ PP,OPNLIX ;IDXFIL FILENAME
IFE TOPS20,<
XCT ULKUP. ;***************
JRST RSTID1 ;
>
IFN TOPS20,<
PUSH PP,.JBFF ;SAVE IT
MOVEI AC0,ICHAN ;MAKE SURE WE HAVE CORE
PUSHJ PP,GETSPC ;GO SEE
JRST GETSPK ;NO CORE RETURN SO COMPLAIN
POP PP,.JBFF ;RESTORE JOBFF
PUSH PP,AC13 ;SAVE AC13
MOVE AC13,AC3 ;SETUP AC13 FOR DEVICE TESTS IN OCPT BELOW
HLRZ I12,D.BL(I16) ;GET BUFFER LOCATION
LDB AC0,[POINT 4,UFRST.,12] ;[467] USE ALREADY ALLOCD CHAN
MOVEM AC0,ICHAN(I12) ;SAVE IT AWAY
PUSHJ PP,OCPT ;USE TOPS20 COMPT. UUO
JRST [CAIE AC1,OPNX9 ;[1143] INVALID SMU ACCESS
JRST RSTID1 ;[1143] IF FNF,GO SET FLAG AND LET USER GO TO OPEN
HRRZI AC0,OF%THW ;YES - SO TRY A VALID ACCESS
ANDCAM AC0,CP.BK3 ;TURN OFF THAWED (ON FROZEN)
MOVE AC1,[10,,CP.BLK];COUNT,,ADR OF ARG-BLK
SETZM CMPTER## ;
COMPT. AC1, ;OPEN FILE IN FROZEN MODE
JRST [MOVEM AC1,CMPTER ;SAVE ASIDE ERR CODE
OUTSTR [ASCIZ /RESET time /]
JRST OCPERR ]
JRST .+1]
POP PP,AC13 ;RESTORE AC13
MOVE AC3,(AC13) ;GET DEVICE NAME
DEVCHR AC3, ;RESTORE DEVICE CHARACTERISTICS
>
MOVEI AC0,ITABL ;
HRR AC1,.JBFF ;
PUSHJ PP,GETSPC ;
JRST GETSPK ;ERROR RETURN
HRLI AC1,-STABL ;
SUBI AC1,1 ;DUMP MODE IOWD
SETZ AC2, ;TERMINATOR
MOVEI AC6,1 ;LOCATION OF
HRRM AC6,UIN. ; IOWD
XCT UIN. ;READ IN STATISTICS BLOCK
SKIPA AC2,1+MXLVL(AC1);[442] GET ORIGINAL # OF IDX LEVELS
JRST RSTIER ;
HLRZ I12,D.BL(I16) ;[442] GET BUFFER LOCATION
MOVNM AC2,OMXLVL(I12) ;[442] SAVE FOR OPNI22
MOVE AC12,1+ISPB(AC1);[442] INDEX SECTORS / BLK
HLRZ AC2,1(AC1) ;GET FILE FORMAT CODE
CAIN AC2,401 ;COMPLAIN IF NOT 401
JRST RSTID7 ;OK
PUSHJ PP,MSVID ;OUTPUT VALUE-OF-ID
OUTSTR [ASCIZ/ is not the index for ISAM,/]
PUSHJ PP,MSFIL. ;OUTPUT FILE NAME AND VID
PUSHJ PP,KILL ;KILL NEVER RETURNS
;HERE IF LOOKUP FAILURE
RSTID1: POP PP,AC1 ;[1143] GET BACK TO RIGHT PLACE ON STACK
HRRZ AC1,ULBLK.+1 ;GET THE ERROR CODE
TRZ AC1,777740 ;WAS IT FILE NOT FOUND?
JUMPN AC1,LUPERR ;EXIT HERE IF OTHER
POP PP,.JBFF ;RESTORE THE STACK ;[1143] ACTUALLY RESTORES
;.JBFF FROM STACK
SETOM D.OPT(I16) ;FILE NOT FOUND - REMEMBER THAT
JRST RSTLOO ; AND SHOOT HIM DOWN AT OPEN TIME
RSTID8: PUSHJ PP,MSFIL. ; [323]OUTPUT FILE NAME
OUTSTR [ASCIZ/ not found at reset time./]
PUSHJ PP,KILL ;[323] FATAL ERROR
RSTID7: HLLZS UIN. ;CLEAR IOWD POINTER
IMULI AC12,200 ;WRDS / SECTOR
CAMLE AC12,MXBUF ;LARGER THAN LARGEST?
MOVEM AC12,MXBUF ;YES, SAVE AS NEW LARGEST
MOVE AC6,1+MXLVL(AC1) ;NUMBER OF INDEX LEVELS
ADDI AC6,2 ;PLUS ONE FOR SAT BLK & ONE FOR SPLITING TOP-LEVEL
IMUL AC12,AC6 ;
;FIND THE LARGEST INDEX ENTRY SIZE
MOVE AC2,1+IESIZ(AC1)
CAMLE AC2,MXIE ;
MOVEM AC2,MXIE ;
;FIND THE MAX BLOCKING-FACTOR
MOVE AC2,DBF+1(AC1) ;
LDB AC6,F.BBKF ;[515] BLOCKING FACTOR IN PROGRAM
; CAMLE AC2,AC6 ;[535] [515] IF NOT LESS OR EQUAL ERROR
CAME AC2,AC6 ;[535] [515] [1062] IF NOT EQUAL, ERROR
JRST RSTER1 ;[515] TELL USER AND GET OUT
CAMLE AC2,MXBF ;
MOVEM AC2,MXBF ;
MOVE AC4,KEYDES+1(AC1) ;[515] GET ISAM KEY DESCRIPTION
MOVEM AC4,OKEYDS+1(AC1) ;[515] SAVE KEY FOR OPEN CHECKING
MOVE AC4,RECBYT+1(AC1) ;[515] GET SIZE OF DATA BLOCK IN BYTES
MOVEM AC4,ORCBYT+1(AC1) ;[515] SAVE IT FOR CHECKING AT OPEN
MOVE AC4,EPIB+1(AC1) ;[515] GET NUM OF ENTRIES/INDEX BLOCK
MOVEM AC4,OEPIB+1(AC1) ;[515] SAVE IT FOR CHECKING AT OPEN
LDB AC6,KY.TP ; GET KEY TYPE
JUMPN AC6,RSTID2 ;BRANCH IF NON-NUMERIC-DISPLAY
MOVE AC4,1+IESIZ(AC1) ;INDEX ENTRY BLOCK SIZE
SUBI AC4,1 ;-2 HDR WRDS, +1 WRD FOR WRAP-AROUND
IMULI AC4,7 ;RESERVE 7 KEY AREAS (2 FOR DEL/RWT CNTRY )
JRST RSTID3 ;
RSTER1: OUTSTR [ASCIZ/ Reset blocking factor for/] ;[515]
PUSHJ PP,MSFIL. ;[515] OUTPUT FILE NAME
OUTSTR [ASCIZ/ differs from user's program ./] ;[515]
PUSHJ PP,KILL ;[515] FATAL ERROR
RSTER2: PUSH PP,AC1 ;[515] SAVE IT FOR LATER
PUSH PP,AC4 ;[515] SAVE IT FOR LATER
OUTSTR [ASCIZ/ Reset key descriptor for/] ;[515]
PUSHJ PP,MSFIL. ;[515] GIVE HIM FILE NAME
OUTSTR [ASCIZ/ differs from program key descriptor.
/]
POP PP,AC4 ;[515] GET AC4 BACK
POP PP,AC1 ;[515] GET AC1 BACK
POPJ PP, ;[515] PROCEED AT YOUR OWN RISK
RSTID2: MOVEI AC4,12 ; (1+1)*5
TRNN AC6,1 ; ODD = 1, EVEN = 2
MOVEI AC4,17 ; (2+1)*5
RSTID3: ADDI AC12,4(AC4) ;NUMBER OF WORDS ALLOCATED
MOVE AC2,F.WDNM(I16)
MOVE AC2,1(AC2) ;DATA FILE DEVICE NAME
MOVEM AC2,UOBLK.+1 ;
XCT UOPEN. ;**************
JRST RSTDE1 ;ERROR
DEVCHR AC2, ;DEVCHR
TXNE AC2,DV.DSK ;DATA FILE
TXNN AC3,DV.DSK ;IDX FILE
JRST RSTER0 ;MUST BE A DSK
LDB AC5,KY.MD ; GET DATA MODE FROM STS-BLOCK
XCT RSTID4(AC5) ; SAME AS FILE TABLE DATA MODE?
JRST RSTID5 ; YES
PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /Data-mode discrepancy/]
MOVE AC2,[BYTE (5)10,31,20,4]
JRST MSOUT1
RSTID4: TLNE FLG,DDMSIX ; SKIP IF NOT SIXBIT
TLNE FLG,DDMEBC ; EBCDIC
TLNE FLG,DDMASC ; ASCII
Z ;
RSTID5: PUSH PP,AC12 ; [375] SAV REG 12
MOVEI AC12,1(AC1) ; [375] SET UP TO GET ISAM REC SIZE
PUSHJ PP,OPNWPB ;RETURNS WRDS/LOGICAL BLOCK IN AC10
; make sure that the internal record area will fit in AUXBUF
LDB AC5,F.BMRS ; Get record size
LDB AC4,[POINT 2,FLG,14] ; Get internal mode
HRRZ AC4,RBPTBL(AC4) ; Get bytes per internal record word
IDIVI AC5,(AC4) ; Get words in record area
SKIPE AC6 ; Skip if no round up
ADDI AC5,1 ; Round up
CAIGE AC10,(AC5) ; Is record area larger than aux buf?
MOVE AC10,AC5 ; Yes, reset so it will hold record area
;BL; 2 LINES INSERTED AT RSTID5 + 3 TO FIX ISAM/RANDOM SHARED BUFFR BUG
TLNE FLG,IDXFIL ;ISAM FILE?
SKIPN ,PAGBUF(I12) ;YES, & PAGE I/O TOO?
JRST RSTID6 ; NO
ADDI AC10,777 ; YES, AT LEAST 512 WD/PG
LSH AC10,-9 ; ROUND
LSH AC10,9 ; OFF
RSTID6: POP PP,AC12 ; [375]RESTORE AC12
CAMLE AC10,MXBUF ;
MOVEM AC10,MXBUF ;SAVE AS LARGEST AUX BUF
ADD AC12,AC10 ;
ADDI AC12,ITABL ;INDEX TABLE LEN
MOVE AC0,AC12 ;
MOVEM AC0,D.OBH(I16) ;SAVE AMOUNT OF CORE REQUIRED
PUSHJ PP,GETSPC ;GRAB SOME CORE AREA
JRST GETSPK ;ERROR RETURN
HLRZ AC4,D.BL(I16) ; Reget buffer location
MOVEM AC5,RCARSZ(AC4) ; Save record area length for START checks
SETZM UOBLK. ;
;NOW SAVE INITIAL CONDITIONS FOR OPEN LOGIC
HRRZ AC4,D.IBL(I16) ; [377A] GET ADR OF "SAVE" AREA
HRLI AC4,ISCLR1+1(AC1); [377A] ADR OF AREA TO BE SAVED
MOVEI AC2,ISMCLR(AC4) ; [377A] END OF AREA TO BE SAVED
TRNE AC4,-1 ; [377A] SKIP IF NOTHING TO SAVE
BLT AC4,(AC2) ; [377A] DOIT
PUSH PP,AC12 ; SAV REG 12
MOVEI AC12,1(AC1) ; POINT AT STAT BLOCK
PUSHJ PP,RSTBPB ; CALC BUFFS PER LOG-BLK
POP PP,AC12 ; RESTORE AC12
JRST RSTDE5 ;RETURN
RSTIER: XCT UGETS. ;INPUT ERROR DURING RESET UUO
TXNE AC2,IO.EOF ;[376] EOF?
OUTSTR [ASCIZ / Unexpected EOF on ISAM index file./] ;[376]
PUSHJ PP,IOERM1 ;
MOVE AC2,[BYTE (5)35,4,10,31,20,2]
JRST KILL ;&KILL
;GET CORE SPECIFIED BY (AC0)
GETSPC: PUSH PP,.JBFF ;INCASE THE CORE UUO FAILS
ADDB AC0,.JBFF ;ASSUME WE'LL GET IT
CAMG AC0,.JBREL ;IS THERE ENOUGH IN FREE CORE
JRST GETSP1 ;YEP
CORE AC0, ;NO, GET SOME MORE CORE
JRST GETSP2 ;ERROR RETURN
GETSP1: POP PP,(PP) ;.JBFF IS GOOD
JRST RET.2 ;NORMAL EXIT
GETSP2: POP PP,.JBFF ;RESTORE .JBFF, CORE UUO FAILED
POPJ PP,
GETSP9: OUTSTR [ASCIZ/Insuficient core for buffer requirements./]
POPJ PP,
GETSPK: PUSHJ PP,GETSP9
JRST KILL
IFE TOPS20,<
;SEE IF MONITOR HAS AUTO LABELING FACILITY.
;SET SUTOLB TO NON-ZERO IF IT DOES.
SETALB: SETZM AUTOLB ; INIT TO NO AUTO FACILITY
MOVE AC1,[%SITLP]
GETTAB AC1,
SETZ AC1, ; ERROR SO OLD STYLE PROCESSING
SKIPE AC1 ; WHAT IS IT?
SETOM AUTOLB ; AUTO FACILITY!
POPJ PP,
>
;SUBROUTINE TO SET UP OVERLAY FILE
;ENTER WITH AC1 = SIXBIT /FILE NAME/ FOR TOPS-10
; OVRFN. = POINT 7,[ASCIZ /FILE NAME/] FOR TOPS-20
SETOVR:
IFN TOPS20,<
; FIRST WE HAVE TO FIND THE NAME OF THE OVERLAY FILE
; WE HAVE THE FILE SPEC OF THE EXE IN EXJFN.
; GET A JFN ON THE EXE AND THEN GET BACK THE PARTS WE WANT
MOVX AC1,GJ%OLD!GJ%SHT
SKIPN AC2,EXJFN.
JRST SETOV0 ;NOT SETUP, USE MAIN PROGRAM NAME
GTJFN%
JRST SETOV4 ;ERROR
MOVE AC2,AC1 ;JFN
HRRO AC1,.JBFF ;WHERE TO STORE STRING
ADDI AC1,.GJF2 ;LEAVE SPACE FOR ARG BLOCK
MOVX AC3,<<FLD .JSAOF,JS%DEV>!<FLD .JSAOF,JS%DIR>!JS%PAF> ;[1137]
JFNS% ;GET STRING
ERJMP SETOV4 ;ERROR
HRRZ AC1,AC2 ;JFN
RLJFN%
JFCL
SETOV0: HRRZ AC3,.JBFF
MOVEM AC3,OVRIX. ;WHERE INDEX BLOCK WILL BE
MOVSI AC1,OVRBLK
HRR AC1,AC3 ;BLT WORD
BLT AC1,.GJJFN(AC3) ;[1176]
MOVE AC1,OVRFN. ;GET BYTE POINTER
MOVEM AC1,.GJNAM(AC3) ;STORE NAME POINTER
HRRZ AC1,AC3 ;OVRBLK
HRROI AC2,.GJF2(AC3) ;STRING
GTJFN%
JRST SETOV4 ;ERROR
MOVEM AC1,OVRJFN## ;STORE JFN
MOVX AC2,OF%RD ;READ 36 BITS
OPENF%
JRST SETOV4 ;ERROR
ADDI AC3,400
HRLI AC3,(POINT 36,) ;FORM INITIAL BYTE POINTER
MOVEM AC3,OVRBF. ;WHERE DATA BUFFER IS
MOVEI AC0,1000
PUSHJ PP,GETSPC ;MAKE SURE WE ALLOCATE SPACE
JRST GETSPK ;FAILED
HRRZ AC2,OVRIX.
HRLI AC2,(POINT 36,)
MOVNI AC3,400
SIN%
ERJMP SETOV6
POPJ PP,
OVRBLK: GJ%OLD
.NULIO,,.NULIO
EXP 0,0,0
POINT 7,[ASCIZ /OVR/]
EXP 0,0,0 ;[1176]
SETOV4: HRROI AC1,[ASCIZ /Cannot find overlay file./]
PSOUT%
JRST KILL
SETOV6: HRROI AC1,[ASCIZ /Input error on overlay file./]
PSOUT%
JRST KILL
>
IFE TOPS20,<
HRLZI AC0,577774 ;[342] TURN OFF CHAN 1
ANDM AC0,OPNCH. ;DOIT
SETO AC0, ;DSK = -1
SKIPN AC3,RN.DEV ;[333] IF DEVICE SPECIFIED, GET IT
HRLZI AC3,'DSK'
SETOV1: MOVEI AC2,IO.SYN+.IOBIN ;SET UP DEVICE
HRRZI AC4,OVRBF. ;
OPEN 1,AC2 ;[342]INIT
JRST SETOV4 ;
MOVSI AC2,'OVR'
SETZB AC3,AC4 ;
SKIPE AC0 ;[333] IF NOT TRYING SYS
MOVE AC4,RN.PPN ;[333] GET OVERLAY PPN
LOOKUP 1,AC1 ;[342]
JRST SETOV5 ;LOOKUP FAILED
INBUF 1,2 ;GET 2 BUFFERS
MOVE AC1,.JBFF ;GET NEXT FREE WORD
MOVEM AC1,OVRIX. ;WHERE INDEX BLOCK WILL BE
MOVEI AC0,400 ;SIZE WE NEED
PUSHJ PP,GETSPC ;GET IT
JRST GETSPK ;FAILED
MOVE AC1,OVRIX. ;
PUSHJ PP,SETOV2 ;
MOVE AC1,OVRIX.
ADDI AC1,200
SETOV2: IN 1, ;[342]
SKIPA AC2,OVRBF. ;
JRST SETOV6 ;
MOVSI AC2,2(AC2) ;
HRR AC2,AC1 ;
BLT AC2,177(AC1) ;
POPJ PP,
SETOV4: OUTSTR [ASCIZ "Cannot initialize overlay."] ;[536]
JRST SETOV7 ;[536]
SETOV5: HRLZI AC3,'SYS' ;[536]TRY SYS IF DSK FAILS
AOJE SETOV1
OUTSTR [ASCIZ "Cannot find overlay file ."]
SKIPN AC3,RN.DEV ;[536]
MOVSI AC3,'DSK' ;[536]
PUSHJ PP,MSDEV1 ;[536] PRINT DEVICE PART
PUSHJ PP,COLON ;[536] PRINT ":"
MOVE AC3,OVRFN. ;[536] FILE NAME
PUSHJ PP,MSDEV1 ;[536] PRINT IT
OUTSTR [ASCIZ /.OVR/] ;[536] EXT
SKIPE AC3,RN.PPN ;[536] ANY PPN?
PUSHJ PP,MSDIR. ;[536] YES, PRINT IT
JRST KILL
SETOV6: OUTSTR [ASCIZ "INPUT error on overlay."]
SETOV7: SKIPN AC3,RN.DEV ;[536]
MOVSI AC3,'DSK' ;[536]
MOVEI AC1,AC3 ;[536] POINT TO WHERE IT IS
PUSHJ PP,MSDEVA ;[536] PRINT DEVICE PART
JRST KILL
>
;TRAP INTERUPT ROUTINE
TRAP.:
IFE TOPS20,<
PORTAL .+1 ; SET EXECUTE ONLY ENTRY POINT
>
SKIPE INTRP.## ;ARE WE ALREADY IN A TRAP?
EXIT ;YES, JUST QUIT
SETOM INTRP. ;SET THE FLAG TO PREVENT LOOPING
MOVE AC0,.JBCNI ; APR STATUS
TXNE AC0,AP.ILM
OUTSTR [ASCIZ/Memory protection violation at user loc /]
TXNE AC0,AP.NXM
OUTSTR [ASCIZ/Non-ex-mem request at user loc /]
TXNE AC0,AP.POV
JRST TRAP1 ;PDLOV
TRAP0: PUSHJ PP,OUTBF1 ;REINIT THE TTY BUFFER
HRLO AC12,.JBTPC ;THE GUILTY LOCATION
PUSHJ PP,PPOUT4 ;OUTPUT THE LOC
HRRZ AC0,.JBTPC ;[312] SEE IF ERROR IS
CAIL AC0,RSTLNK ;[312] IN RSTLNK
CAIL AC0,RSTLNX ;[312] ROUTINE.
JRST KILL ;[312] NO
OUTSTR [ASCIZ /$Failing routine is RSTLNK in CBLIO
MACRO routine loaded in place of COBOL subroutine?/]
JRST KILL ;AND KILL
TRAP1: OUTSTR [ASCIZ/?LBLPDL Push-down-list overflow at /]
JRST TRAP0
KPROG.: OUTSTR [ASCIZ "?LBLADP Attempt to drop off end of program."]
JRST KILL.
KDECL.: OUTSTR [ASCIZ "?LBLADD Attempt to drop off end of DECLARATIVES."]
JRST KILL.
ILLC.: OUTSTR [ASCIZ "?LBLRCL Recursive call."]
JRST KILL.
;GOTO IS THE ERROR EXIT FOR UNALTERED "GOTO"
;STATEMENTS WHICH DID NOT PROVIDE AN OBJECT PARAGRAPH NAME.
GOTO.: OUTSTR [ASCIZ /?LBLEUG Encountered an unaltered GOTO with no destination.
/]
;FALL THRU
;KILL TYPES OUT THE LOCATION OF THE LAST COBOL VERB,
;STOPS ALL IO AND EXITS TO THE MONITOR.
KILL: PUSHJ PP,TYPSTS ;TYPE ERROR-NUMBER, BLOCK # + REC #
KILL.:
PUSHJ PP,VEROUT ;TYPE THE VERSION NUMBER
OUTSTR [ASCIZ /
?/]
SKIPE TRAC1. ;[270] IS THIS A PRODUCTION PROGRAM (I.E. /P)?
PUSHJ PP,@TRAC1. ;NO, CALL BTRAC. IN TRACE ROUTINE
PUSHJ PP,PPOUT. ;TYPE THE LOCATION OF LAST COBOL VERB
HRRZ AC16,FILES. ;[444] GET START OF FILE TABLES
JUMPE AC16,STOPR2 ;[444] NO FILES, DON'T BOTHER
KILL1: MOVE FLG,F.WFLG(I16) ;[444] GET FLAGS FOR THIS FILE
MOVE AC13,D.DC(I16) ;[1033] [444] GET DEV CHARACTERISTICS
TLNE FLG,OPNOUT ;[622] [444] OPEN FOR OUTPUT
TLNE FLG,OPNIN ;[622] [444] YES, OPEN FOR OUTPUT ONLY
TRNA ;[1033] SKIP IF INPUT FILE
JRST KILL1A ;[1033] JUMP IF OUTPUT ONLY
TXNE AC13,DV.MTA ;[1033] MAG TAPE?
JRST KILL2A ;[1033] YES, DO ABORT CLOSE
JRST KILL4 ;[444] NO, CHECK NEXT ONE
KILL1A: TXNN AC13,DV.DSK ;[1033] [444] DISK?
JRST KILL4 ;[444] NO, TRY NEXT FILE
SETZB AC2,AC3 ;[444]
MOVE AC10,[POINT 6,2] ;[444] SET UP TO PUT VID IN 2 AND 3
MOVE AC5,F.WVID(I16) ;[444] GET PTR TO VALUE OF ID
PUSHJ PP,OPNVID ;[444] GET IT INTO AC2 AN AC3
HRRZ AC1,FILES. ;[444] SET UP FOR SUB-LOOP
KILL2: CAIN AC16,(AC1) ;[444] COMPARING AGAINST ITSELF
JRST KILL3 ;[444] YES, DON'T BOTHER
MOVE AC13,D.DC(AC1) ;[444] GET DEV CHARS
TXNN AC13,DV.DSK ;[444] IS IT A DISK?
JRST KILL3 ;[444] NO, IGNORE
MOVE FLG,F.WFLG(AC1) ;[444] GET FLAGS
TLNN FLG,OPNIN ;[444] IS IT OPEN FOR INPUT
JRST KILL3 ;[444] NO, CAN'T BE SUPERSEDING
SETZB AC14,AC15 ;[444]
MOVE AC10,[POINT 6,14] ;[444] PUT VID IN 14 AND 15
MOVE AC5,F.WVID(AC1) ;[444] BYTE PTR TO VALUE OF ID
PUSHJ PP,OPNVID ;[444] GET IT
CAMN AC2,AC14 ;[444] FILENAMES EQUAL?
CAME AC3,AC15 ;[444] YES, EXTENSIONS EQUAL?
JRST KILL3 ;[444] NO, FORGET IT
KILL2A: LDB AC4,DTCN. ;[1033] [444] GET CHANNEL NUMBER
LSH AC4,27 ;[444] POSITION IT
MOVE AC5,[CLOSE CL.RST] ;[444] SET UP A CLOSE
ADD AC5,AC4 ;[444] ADD CHANNEL
XCT AC5 ;[444] CLOSE FILE, DELETING NEW
;[444] FILE, LEAVING OLD INPUT
JRST KILL4 ;[444] GO CHECK ANOTHER ONE
KILL3: HRRZ AC1,F.RNFT(AC1) ;[444] GET ANOTHER FILE FOR SUB-LOOP
JUMPN AC1,KILL2 ;[444] GO CHECK, IF ANY LEFT
KILL4: HRRZ AC16,F.RNFT(AC16) ;[444] GET ANOTHER FILE TO CHECK
JUMPN AC16,KILL1 ;[444] GO CHECK IF ANY LEFT
JRST STOPR2
;TYPE OUT SOME ERROR INFORMATION
TYPSTS: OUTSTR [ASCIZ /
$ Error-number = /]
TYPST1: MOVE AC0,FS.EN ;ERROR-NUMBER
PUSHJ PP,PUTDEC ;TYPE IT
MOVE AC0,FS.BN ;BLOCK-NUMBER
JUMPE AC0,TYPST2 ;
OUTSTR [ASCIZ / Block-number = /]
PUSHJ PP,PUTDEC ;
TYPST2: MOVE AC0,FS.RN ;RECORD-NUMBER
JUMPE AC0,RET.1 ;
OUTSTR [ASCIZ / Record-number = /]
JRST PUTDEC ;RETURN
;STOPR. IS CALLED WITH A "PUSHJ PP,STOPR." ALL FILES ARE
;CLOSED VIA COBOL CLOSE UUOS AND A CALLI EXIT IS EXECUTED.
STOPR.: HRRZ AC16,FILES. ;LOOP THROUGH THE FILE TABLES
JUMPE AC16,STOPR2 ;DONE
STOPR1: HRLI AC16,001040 ;STANDARD CLOSE UUO
MOVE FLG,F.WFLG(I16) ;GET THE FLAGS
LDB AC1,F.BRMS ; Get RMS flag bit
JUMPN AC1,STOP1C ;Jump if this is an RMS file.
TLNE FLG,OPNIN+OPNOUT; Skip if the file is not open
PUSHJ PP,C.CLOS ;Close file
JRST STOPRA ;and continue
;Check RMS file to see if it is open
STOP1C: HRRZ AC1,D.F1(I16) ;Get flag bits
TXNN AC1,LF%INP!LF%OUT ;Is file open?
JRST STOPRA ;No
PUSH PP,AC16 ;SAVE AC16
HRRZ AC1,I16 ;NO FLAG BITS,,FILTAB
PUSH PP,AC1 ;STORE ARGLIST ON THE STACK
MOVEI AC16,(PP) ;POINT TO THE STACK ARG LIST
PUSHJ PP,CL.MIX## ;CALL RMS CLOSE
POP PP,(PP) ;THROW AWAY ARGLIST
POP PP,AC16 ;RESTORE AC16
STOPRA: HRRZ AC16,F.RNFT(I16);NEXT FILE
JUMPN AC16,STOPR1 ;LOOP
STOPR2: MOVE AC0,FS.IEC ; NUMBER OF IGNORED ERRORS
JUMPE AC0,STOPR3 ; NONE IGNORED
OUTSTR [ASCIZ /%LBLIGN /] ;
CAIE AC0,1 ; ONLY ONE?
JRST STPR2A ; NO
OUTSTR [ASCIZ/ 1 error ignored./]
JRST STOPR3 ; CONT
STPR2A: PUSHJ PP,PUTDEC ; TYPE NUMBER
OUTSTR [ASCIZ/ errors ignored./]
STOPR3: PUSHJ PP,@HPRT.## ; PRINT HISTORY REPORT IF ANY
IFN DBMS,<
SKIPE DBMLOK## ;IF A DBMS PROGRAM
PUSHJ PP,@DBSTP.## ; DO DBMS CLEANUP
>
EXIT ;CALLI EXIT
JRST .-1 ;For TOPS20: Stay stopped.
; C.STOP IS CALLED WITH A "PUSHJ PP,C.STOP" AFTER THE OPERATOR
; TYPES "CONTINUE" IT RETURNS TO THE CALLING ROUTINE
C.STOP: OUTSTR [ASCIZ /
$ type CONTINUE to proceed .../]
EXIT 1, ; WAIT FOR CONT
POPJ PP, ;
;TYPE THE VERSION NUMBER OF COBOL, LIBOL, SORT, DBMS, RMS, etc.
VEROUT: PUSHJ PP,OUTBF. ;DUMP THE CURRENT BUFFER TO SYNC WITH TTCALLS
OUTSTR [ASCIZ /
COBOL /]
MOVE AC12,COBVR. ;GET COBOL VERSION NUMBER
PUSHJ PP,VEROU0 ;TYPE VERSION NUMBER IN STANDARD FORMAT
OUTSTR [ASCIZ /, COBOTS /]
MOVE AC12,LIBVR. ;GET VERSION NUMBER
PUSHJ PP,VEROU0 ;TYPE THE VERSION NUMBER IN STANDARD FORMAT
SKIPE AC12,SRTVR. ;GET SORT VERSION NUMBER
PUSHJ PP,[OUTSTR [ASCIZ /, SORT /]
JRST VEROU0] ;TYPE THE VERSION NUMBE IN STANDARD FORM
IFN DBMS,<
SKIPE AC12,DBMVR.## ;GET DBMS VERSION NUMBER
PUSHJ PP,[OUTSTR [ASCIZ /, DBMS /]
JRST VEROU0] ;TYPE THE VERSION NUMBER IN STANDARD FORM
>
SKIPE AC12,RMSVR.## ;GET RMS VERSION NUMBER
PUSHJ PP,[OUTSTR [ASCIZ /, RMS /]
JRST VEROU0] ;TYPE THE VERSION NUMBER IN STANDARD FORM
JRST DSPL1. ;"CRLF" AND EXIT
VEROU0: ROT AC12,3 ;GET WHO FIELD OUT OF THE WAY
MOVEI AC0,3 ;
PUSHJ PP,NUMOUT ;THE VERSION NUMBER
LDB AC1,[POINT 6,AC12,5] ;GET MINOR VERSION
SOJL AC1,VEROU2 ;DON'T OUTPUT IF NULL
IDIVI AC1,^D26 ;^D26="Z", ^D27="AA"
JUMPE AC1,VEROU1 ; DON'T OUTPUT FIRST IF NULL
PUSH PP,AC2 ;SAVE 2ND
MOVEI C,100(AC1) ;GET 1ST LETTER
PUSHJ PP,OUTCH. ;OUTPUT IT
POP PP,AC2
VEROU1: MOVEI C,101(AC2) ;GET 2ND LETTER
PUSHJ PP,OUTCH. ;OUTPUT IT
VEROU2: MOVEI AC0,6 ;
LSH AC12,6 ;SHIFT EDIT # INTO LEFT HALF
TLNN AC12,-1
JRST VEROU3 ;DONE IF NO EDIT NUMBER
MOVEI C,"(" ;
PUSHJ PP,OUTCH. ;
PUSHJ PP,NUMOUT ;THE EDIT NUMBER
MOVEI C,")" ;
PUSHJ PP,OUTCH. ;
VEROU3: ROT AC12,3 ;GET WHO FIELD BACK IN RHS
JUMPE AC12,OUTBF. ;DON'T OUTPUT IF NULL
MOVEI C,"-" ;SEPARATE BY HYPHEN
PUSHJ PP,OUTCH.
MOVEI C,"0"(AC12) ;TURN INTO ASCII
PUSHJ PP,OUTCH. ;STORE
JRST OUTBF. ;OUTPUT AND RETURN
NUMOUT: MOVEI C,6 ;HALF AN ASCII ZERO
LSHC C,3
TRNN C,7 ;SKIP LEADING ZEROES
SOJG AC0,NUMOUT
JUMPL AC0,RET.1
PUSHJ PP,OUTCH.
MOVEI C,6
LSHC C,3
SOJG AC0,.-3
LSHC C,-3 ;RESTORE LAST DIGIT
POPJ PP,
; TYPES OUT THE LISTING'S LOCATION OF "PUSHJ PP,VERB"
; OR THE PUSHJ'S RETURN ADR IF NO PUSHJ IS FOUND
; (SBPSA.) NON-ZERO IF A SUBPROGRAM CALL IS ACTIVE
; LH IS (RH(17)) I.E. PUSH DOWN STACK
; RH IS ENTRY POINT'S ADDRESS
; ENTRY-1 SIXBIT /NAME-OF-ENTRY-POINT/
; ENTRY-2 LH: FIRST LOCATION OF CURRENT (SUB)PROGRAM
; RH: SIXBIT /SUBPROGRAM-NAME/
PPOUT.: OUTSTR [ASCIZ /Last COBOL verb called from /]
HLRO AC12,PP ; FIND THE BEG OF THE STACK
ADD AC12,PUSHL. ; --
SUBI AC12,(PP) ; --
MOVNS AC12 ; --
SKIPE AC11,SBPSA. ; THIS A SUBPROGRAM OR OVERLAY?
HLRZ AC12,AC11 ; YES - GET FIRST ENTRY FROM HERE
ADDI 12,1 ; 12 HAS POINTER TO FIRST ENTRY ON STACK
MOVEI AC1,0 ; ASSUME NO COBDDT
SKIPE CB.DDT ; ANY COBDDT?
MOVEI AC1,2 ; YES - THERE ARE 2 ENTRIES ON LIST
MOVE AC2,LIBSW. ; GET MULTIPLE PERFORM FLAG
TRNE AC2,MPWC.S ; MULTIPLE-PERFORMS?
ADDI AC1,1 ; YES - ANOTHER ENTRY ON PDLIST
IMUL AC1,LEVEL. ; ENTRIES PER LEVEL.
ADD AC12,AC1 ; SKIP OVER COBDDT+PERF. STUFF
HRRZ AC12,(AC12) ; GET RETURN ADR MINUS ONE
MOVEI AC2,5 ; LOOK BACK 5 LOCS FOR A PUSHJ
MOVEI AC1,-1(AC12) ; START AT THE RETURN ADR-1
PPOUT1: HLRZ AC3,(AC1) ; GET THE PUSHJ TO THE RIGHT HALF
SUBI AC1,1 ; SET UP FOR NEXT COMPARE
CAIE AC3,(PUSHJ PP,) ; WHAT IS IT?
SOJG AC2,PPOUT1 ; NOT A PUSHJ SO LOOP
JUMPE AC2,PPOUT2 ; NOT THERE SO GIVE RET ADR-1
HRRI AC12,1(AC1) ; THE PUSHJ'S ADR
PPOUT2: SKIPN AC11,SBPSA. ; IF SUBPROGRAM
MOVE AC11,%F.PTR ; NO - MAIN PROGRAM
HLRZ AC11,-2(AC11) ; GET START ADR
TRZ AC11,400000 ; TURN OFF BIT18 IF ON
SUB AC12,AC11 ; GET OFFSET FROM HERE
HRLOI AC12,(AC12) ; XWD ADR,,-1
PPOUT4: MOVEI C,6 ; HALF OF AN ASCII ZERO-60
LSHC C,3 ; APPEND THE OCTAL NUMBER
PUSHJ PP,OUTCH. ; DEPOSIT IT IN THE TTY BUFFER
TRNE AC12,-1 ; HAVE WE SEEN SIX NUMBERS?
JRST PPOUT4 ; NO, LOOP
PUSHJ PP,OUTBF. ; DUMP IT NOW
PPOT4.: OUTSTR [ASCIZ/ in program /]
SKIPN AC3,SBPSA. ; SKIP IF ANY SUBPRGMS
JRST PPOUT6 ; NONE
PPOUT5: OUTSTR [ASCIZ /
/]
HRRI AC1,(AC3) ; GET ADR OF SUBPRG NAME
HRL AC1,-2(AC1) ;
TLNE AC1,-1 ;
HLRZS AC1 ; IF IT'S ZERO
SUBI AC1,1 ; ITS SAME AS ENTRY POINT
HRLI AC1,(POINT 6) ; MAKE A BYTE-PTR
MOVEI AC4,6 ; ONLY 6 CHARS PER NAME
PUSHJ PP,MSVID4 ; TYPE IT
OUTSTR [ASCIZ / entry /]
HRRI AC1,-1(AC3) ; MAKE BYTE-PTR TO ENTRY POINT
HRLI AC1,(POINT 6) ; FINISH BYTE-POINTER
MOVEI AC4,6 ; 6 IS MAX
PUSHJ PP,MSVID4 ; TYPE IT
OUTSTR [ASCIZ / called from/]
MOVS AC3,AC3 ; ANY MORE SUBPRGMS?
SKIPE AC3,(AC3) ; SKIP IF NOT
JRST PPOUT5 ; THERE ARE
PPOUT6: MOVE AC1,%F.PTR ; GET THE PROGRAM NAME
MOVEI AC1,-1(AC1) ; THIS IS IT
HRLI AC1,(POINT 6) ; MAKE BYTE POINTER
MOVEI AC4,6 ; NAME HAS 6 CHARS
PUSHJ PP,MSVID4 ; DUMP THE NAME
JRST DSPL1. ; APPEND "CRLF", THEN EXIT
; SUSPC: A SUBROUTINE THAT DETERMINES THE AMOUNT OF SPACE REQUIRED
; FOR SIMULTANEOUS UPDATE, AND GETS IT. IT ALSO INITIALIZES THE
; GLOBAL VARIABLES SU.RRT, SU.EQT, SU.DQT, SU.MQT,
; AND SU.FBT TO POINT TO THE RETAINED RECORDS TABLE, THE ENQUEUE
; TABLE, THE DEQUEUE TABLE, THE MODIFY TABLE, AND THE FILL/FLUSH
; BUFFER TABLE.
;
; ARGUMENTS:
;
; AC14 CONTAINS THE ADDRESS OF A WORD CONTAINING THE
; STARTING ADDRESS OF THE MAIN PROGRAM.
;
; CHANGES:
;
; AC0
; AC1
; AC2
; AC3
; WHATEVER GETSPC CHANGES
;
; CALLS:
;
; SUSPC1
; GETSPC
;
; ERRORS:
;
; NOT ENOUGH SPACE AVAILABLE FOR SIMULTANEOUS UPDATE
; REQUIREMENTS. IF THIS OCCURS, A MESSAGE IS SENT
; TO TTY AND A JRST KILL. IS EXECUTED.
;;;;;
;
; IN ITS CALCULATIONS FOR CORE ALLOCATIONS FOR SMU OPTION 1, THIS ROUTINE
; USES AS INPUT THE VALUES PUT IN THE FIELDS %SURRT, %SUEQT, AND %SUFBT
; BY THE COMPILER. THESE VALUES ARE SUPPOSED TO REPRESENT THE LARGEST
; SIZES REQUIRED FOR THE RETAINED RECORDS TABLE, THE ENQ TABLE AND THE
; FILL-FLUSH BUFFER TABLE. IT IS SUPPOSED TO CALCULATE THE THREE VALUES
; FOR THE SIZES OF THESE AREAS SEPARATELY. HOWEVER, THEY SOMEHOW GET MASHED
; INTO THE SIZE OF THE ENQ TABLE. NOT DESIRING TO CHANGE THE ALGORITHM
; DRASTICALLY, I HAVE MADE THE ASSUMPTION THAT 5 TIMES THE SIZE GIVEN
; IN %SUEQT IS SUFFICIENT BECAUSE 4 TIMES WAS SUFFICIENT WITH SMU OPTION 1
; WITH NON-RMS FILES. SINCE I ADDED A FIFTH OPEN-TIME LOCK FOR RMS FILES
; THE FACTOR NOW BECOMES 5. THIS NUMBER IS TOO BIG, BUT IT WOULD BE
; DIFFICULT TO TRIM WITHOUT INTRODUCING SEVERE PROBLEMS WITHOUT TOTALLY
; RE-DOING THE ALGORITHM. SEE THE HEADER OF THE ROUTINE SUSPC1: FOR A
; LITTLE MORE INFORMATION ON THE PARAMETERS.
;
;;;;;
EXTERN SU.RRT, SU.EQT, SU.FBT, SU.DQT, SU.MQT
SUSPC: HRRZ AC1,0(AC14) ;GET STARTING ADDRESS OF MAIN PROGRAM
SETZM SU.RRT ;INITIALIZE GLOBAL VARIABLES
SETZM SU.EQT
SETZM SU.FBT
PUSHJ PP,SUSPC1 ;EXAMINE THE MAIN PROGRAM AND ALL ITS
;SUBPROGRAMS TO DETERMINE THE MAXIMUM
;REQUIREMENTS FOR SIMULTANEOUS UPDATE
;SPACE
MOVE AC0,SU.EQT ;[437]
IMULI AC0,5 ;[537];NOTE: ONLY RMS FILES HAVE UP TO 5 LOCKS AT OPEN TIME
; AND THE OTHERS HAVE ONLY UP TO 4, BUT WE AREN'T GOING
; TO GO THRU THE FILE TABLES NOW AT RESET TIME JUST TO SAVE A
; MEAGER FEW WORDS OF CORE.
ADD AC0,SU.RRT ;[437] (THERE ARE FOUR ENQ/DEQ TABLES)
ADD AC0,SU.FBT
JUMPE AC0,RET.1 ;RETURN IF NO SPACE REQUIRED
PUSH PP,.JBFF ;SAVE .JBFF ON THE STACK
PUSHJ PP,GETSPC ;GET THE SPACE, IF POSSIBLE
JRST SUERR ;JUMP IF NOT POSSIBLE
POP PP,AC1
MOVE AC2,AC1
ADD AC2,SU.RRT
MOVEM AC1,SU.RRT ;PUT RETAINED RECORDS TABLE AT ADDRESS
;OF FORMER .JBFF
MOVE AC1,AC2 ;PUT ENQ/DEQ TABLES AT END OF THE
;RETAINED RECORDS TABLE
ADD AC2,SU.EQT
MOVEM AC2,SU.DQT
ADD AC2,SU.EQT
MOVEM AC2,SU.MQT
ADD AC2,SU.EQT
MOVEM AC1,SU.EQT
MOVEM AC2,SU.FBT ;PUT THE FILL/FLUSH BUFFER TABLE AT THE
;END OF THE ENQ/DEQ TABLES
POPJ PP, ;WE'RE ALL DONE
SUERR: OUTSTR [ASCIZ"Not enough space available to meet the requirements of simultaneous update. Please relink to provide more space."]
JRST KILL.
; SUSPC1: A SUBOUTINE TO DETERMINE THE MAXIMUM REQUIREMENT FOR SIMULTANEOUS
; UPDATE SPACE OF A PROGRAM AND ITS SUBPROGRAMS
;
; ARGUMENTS:
;
; AC1: THE STARTING ADDRESS OF THE PROGRAM
;
; IN THE %FILES AREA OF THE PROGRAMS THERE ARE THESE QUANTITIES:
;
; %SURRT: THE SPACE REQUIRED BY THE PROGRAM FOR
; THE RETAINED RECORDS TABLE
;
; %SUEQT: THE SPACE REQUIRED BY THE PROGRAM FOR
; EACH OF THE ENQ/DEQ TABLES
;
; %SUFBT: THE SPACE REQUIRED BY THE PROGRAM FOR
; THE FILL/FLUSH BUFFER TABLE
;
; RESULTS:
;
; SU.RRT IS SET TO THE MAX OF SU.RRT AND %SURRT IN THE
; PROGRAM AND EACH OF ITS SUBPROGRAMS
;
; SU.EQT IS SET TO THE MAX OF SU.EQT AND %SUEQT IN THE
; PROGRAM AND EACH OF ITS SUBPROGRAMS
;
; SU.FBT IS SET TO THE MAX OF SU.FBT AND %SUFBT IN THE
; PROGRAM AND EACH OF ITS SUBPROGRAMS
;
; CHANGES:
;
; AC1
; AC2
; AC3
;
; ASSUMPTIONS:
;
; SU.RRT, SU.EQT, SU.FBT ARE INITIALIZED BEFORE THIS
; ROUTINE IS CALLED THE FIRST TIME
;
; NOTES:
;
; THE ROUTINE CALLS ITSELF RECURSIVELY.
SUSPC1: HRRZ AC2,(AC1) ;CHECK TO SEE IF THIS SUBROUTINE IS IN
JUMPN AC2,RET.1 ; A LINK-10 OVERLAY AREA.
; ((AC1)) = SKIPA 0,0 <==> IT ISN'T
; ((AC1)) = JSP 1,MUMBLE <==> IT IS.
HRRZ AC2,1(AC1) ;ADDRESS OF %FILES TO AC2
HLRZ AC3,(AC2) ;HAVE WE BEEN HERE BEFORE?
JUMPE AC3,RET.1 ;YES, LEAVE.
MOVE AC3,%SURRT(AC2) ;SET SU.RRT TO MAX OF SU.RRT AND %SURRT
CAMLE AC3,SU.RRT
MOVEM AC3,SU.RRT
MOVE AC3,%SUEQT(AC2) ;SET SU.EQT TO MAX OF SU.EQT AND %SUEQT
CAMLE AC3,SU.EQT
MOVEM AC3,SU.EQT
MOVE AC3,%SUFBT(AC2) ;SET SU.FBT TO MAX OF SU.FBT AND %SUFBT
CAMLE AC3,SU.FBT
MOVEM AC3,SU.FBT
HRRZS (AC2) ;MARK THIS SUBPROGRAM AS DONE.
HLRZ AC2,1(AC1) ;GET ADDRESS OF SUBPROGRAM LIST
SUSPCX: SKIPN AC1,0(AC2)
POPJ PP, ;RETURN IF NO MORE SUBPROGRAMS
PUSH PP,AC2 ;SAVE AC2 ON STACK
PUSHJ PP,SUSPC1 ;CALL OURSELVES TO PROCESS SUBPROGRAM
POP PP,AC2 ;RESTORE AC2
AOJA AC2,SUSPCX ;POINT TO NEXT SUBPROGRAM
SUBTTL DISPLAY VERB
;CALLING SEQUENCE IS PUSHJ PP,DSPLY. WITH THE CALLING ARG-LIST IN AC 16.
;THE AC16'S EFFECTIVE ADDRESS CONTAINS A MODIFIED BYTE POINTER TO THE
;ASCII CHARACTER STRING. MODIFICATIONS FOLLOW:
; IF BIT 6 IS SET LEADING SPACES AND HOR-TABS ARE SUPPRESSED.
; IF BIT 7 IS SET A "CRLF" IS APPENDED TO THE CHARACTER STRING.
; BITS 8-17 CONTAIN THE NUMBER OF CHARACTERS TO BE DISPLAYED.
;THE ONLY ERROR EXIT IS A CALL TO C.STOP CAUSED BY "TELETYPE OUTPUT
;ERROR". A NORMAL RETURN IS A POPJ PP,.
;MODIFIED ACS ARE: 15,11,7,6,AND 1.
;AC16= ;THE CALLING ARG-LIST
;AC15= ;BYTE POINTER
;AC6= ;CHARACTER COUNT
;AC1= ;TOPS-20 ONLY
;AC4= ;BLANK COUNTER (TO SUPPRESS TRAILING BLANKS)
;AC12 ;MUST NOT BE USED
DOPFS.: POINT 10,(I16),17 ;DISPLAY OPERAND FIELD SIZE
DSPLY.: SKIPE TTYOPN ;IS THERE A TTY FILE OPEN?
PUSHJ PP,DSPTO ;YES, DUMP THE BUFFER BEFORE DISPLAYING
MOVE AC15,(I16) ;GET DISPLAY OPERAND
MOVE FLG,AC15 ;SAVE IT FOR THE FLAGS
LDB AC6,DOPFS. ;NUMBER OF CHARS. TO BE DISPLAYED
TLZ AC15,7777 ;
TLO AC15,700 ;(AC15) IS BYTE POINTER TO CHARS.
SETZ AC4, ;CLEAR BLANK COUNTER
TXNN FLG,DIS%NM ;NUMERIC?, SUPPRESS LEADING SPACES AND TABS
JRST DSPL4 ;NO
DSPL2: ILDB C,AC15 ;GET A CHARACTER.
JUMPE C,DSPL3 ;DON'T PASS NULLS BUT COUNT THEM
CAIE C," " ;SPACE
CAIN C," " ;OR TAB?
JRST DSPL3 ;YES
JRST DSPL5 ;NO, FIRST OUTPUT CHAR FOUND
DSPL3: SOJG AC6,DSPL2 ;LOOP
JRST DSPL7 ;END OF INPUT
DSPL4: ILDB C,AC15 ;GET A CHARACTER
JUMPE C,DSPL6 ;COUNT NULLS BUT DON'T OUTPUT THEM
CAIN C," " ;BLANK?
AOJA AC4,DSPL6 ; YES, DON'T OUTPUT IF TRAILING BLANK
JUMPE AC4,DSPL5 ;JUMP IF NO ACCUMULATED BLANKS
PUSH PP,C ; SAVE THIS NON-BLANK
MOVEI C," " ;THE BLANKS WE SAW WERE NOT TRAILING BLANKS
PUSHJ PP,OUTCH. ; SO OUTPUT THEM
SOJG AC4,.-1 ;[673] REPLACE EDIT 651
POP PP,C ;RESTORE THE CHARACTER AFTER THE BLANKS
DSPL5: IDPB C,TTOBP. ;DEPOSIT CHARACTER IN BUFFER
SOSG TTOBC. ;BUFFER FULL?
PUSHJ PP,OUTBF. ;YES
DSPL6: SOJG AC6,DSPL4 ;LOOP
DSPL7: TXNN FLG,DIS%LF ;LAST FIELD?, APPEND CR-LF AT END?
JRST DSPL8 ;[533] NO, JUST OUTPUT WHAT WE HAVE
DSPL1.: MOVEI C,$CR ;APPEND CR-LF
PUSHJ PP,OUTCH. ; .
MOVEI C,$LF ; .
PUSHJ PP,OUTCH. ; .
JRST OUTBF. ;OUTPUT BUFFER AND EXIT
DSPL8: JUMPE AC4,DSPL8A ;[533] IF NO MORE TRAILING SPACES, EXIT
MOVEI C," " ;[533] GET ONE
PUSHJ PP,OUTCH. ;[533] AND OUTPUT IT
SOJG AC4,.-1 ;[533] LOOP BACK FOR ALL SPACES
DSPL8A: JRST OUTBF. ; OUTPUT BUFFER AND EXIT
;HERE FOR DISPLAY OF SIXBIT DATA
DSPL.6: SKIPE TTYOPN ;IS THERE A TTY FILE OPEN?
PUSHJ PP,DSPTO ;YES, DUMP THE BUFFER BEFORE DISPLAYING
MOVE AC15,(I16) ;GET DISPLAY OPERAND
MOVE FLG,AC15 ;SAVE IT FOR THE FLAGS
LDB AC6,DOPFS. ;NUMBER OF CHARS. TO BE DISPLAYED
TLZ AC15,7777 ;
TLO AC15,600 ;(AC15) IS BYTE POINTER TO CHARS.
SETZ AC4, ;CLEAR BLANK COUNTER
TXNN FLG,DIS%NM ;NUMERIC?, SUPPRESS LEADING SPACES AND TABS
JRST DSPL64 ;NO
DSPL62: ILDB C,AC15 ;GET A CHARACTER.
JUMPN C,DSPL65 ;OUTPUT FIRST NON-SPACE
SOJG AC6,DSPL62 ;LOOP
JRST DSPL7 ;END OF INPUT
DSPL64: ILDB C,AC15 ;GET A CHARACTER
DSPL65: ADDI C," " ;CONVERT TO ASCII
CAIN C," " ;A BLANK?
AOJA AC4,DSPL67 ; YES, DON'T OUTPUT TRAILING BLANKS
JUMPE AC4,DSPL66 ;CHECK FOR BLANKS FOLLOWED BY NON-BLANKS
PUSH PP,C ; (YUP) OUTPUT BLANKS IN THE MIDDLE
MOVEI C," "
PUSHJ PP,OUTCH.
SOJG AC4,.-1 ;[673] REPLACE 664 LEAVE AS IT WAS BEFORE
POP PP,C ;GET THE NON-BLANK CHAR BACK
DSPL66: IDPB C,TTOBP. ;DEPOSIT CHARACTER IN BUFFER
SOSG TTOBC. ;BUFFER FULL?
PUSHJ PP,OUTBF. ;YES
DSPL67: SOJG AC6,DSPL64 ;LOOP
JRST DSPL7 ;SEE IF CR-LF NEEDED
;HERE FOR ASCIZ TEXT
DSPL.7: SKIPE TTYOPN ;IS THERE A TTY FILE OPEN?
PUSHJ PP,DSPTO ;YES, DUMP THE BUFFER BEFORE DISPLAYING
;IFE TOPS20,<
OUTSTR (I16) ;OUTPUT THE TEXT STRING
;>
REPEAT 0,< ;ALTMODE COMES OUT AS DOLLAR SIGN
IFN TOPS20,<
MOVEI 1,(I16)
HRLI 1,(POINT 7,) ;BUILD BYTE PTR
PSOUT% ;OUTPUT THE STRING
>;END IFN TOPS20
>;END REPEAT 0
POPJ PP,
DSPTO: PUSH PP,AC16 ;SAVE AC16
MOVE AC16,TTYOPN ;GET FILE-TABLE ADR FOR ERROR ROUTINES
PUSHJ PP,SETCN. ;SETUP IO CHANNEL
PUSHJ PP,WRTOUT ;DUMP THE BUFFER
POP PP,AC16 ;RESTORE
POPJ PP, ;EXIT
OUT6B.: ADDI C," " ;CONVERT A SIXBIT CHAR
OUTCH.: IDPB C,TTOBP. ;DEPOSIT CHAR. IN BUFFER.
SOSLE TTOBC. ;DUMP THE BUFFER?
POPJ PP, ; NO.
;OUTPUT A TTY BUFFER. ***POPJ***
OUTBF.: PUSH PP,C ;[673] SAVE C
SETZ C, ;ASCIZ TERMINATOR
IDPB C,TTOBP. ;
OUTSTR TTOBF. ;DUMP THE BUFFER
REPEAT 0,< ;*** FIX DURING FIELD TEST ***
IFN TOPS20,<
PUSH PP,1
MOVE 1,[POINT 7,TTOBF.]
PSOUT% ;DUMP THE BUFFER
POP PP,1
>
>;END REPEAT 0
TRNA ;WE HAVE C SAVED ALREADY
OUTBF1: PUSH PP, C ;SAVE C
MOVE C,[POINT 7,TTOBF.]
MOVEM C,TTOBP. ;INITIALIZE THE BYTE-POINTER
MOVEI C,^D132 ;A 132 CHAR BUFFER
MOVEM C,TTOBC. ;INITIALIZE THE BYTE-COUNT
POP PP,C ;[673] RESTORE C
POPJ PP, ;
;RETURN A CHARACTER IN C
;IGNORE "CARRIAGE-RETURN"
;SKIP EXIT IF NOT AN END-OF-LINE CHAR
;POPJ IF EOL, EOL = LF, VT, FF OR ALT-MODE
GETCH.: INCHWL C ;[267] INPUT A LINE, FIRST CHAR TO C
CAIN C,$CR
JRST GETCH.
CAIN C,$ALT
JRST GETCH1
CAIG C,$FF
CAIGE C,$LF
AOSA (PP)
GETCH1: MOVEI C,$LF
POPJ PP,
SUBTTL OPEN VERB
;AN OPEN VERB LOOKS LIKE:
;FLAGS,,ADR WHERE ADR = FILE TABLE ADDRESS
;OPN%OU OPEN FOR OUTPUT
;OPN%IN OPEN FOR INPUT
;OPN%NR DON'T REWIND
;OPN%EX [74] OPEN EXTENDED (APPEND FILOP.)
;OPN%RV [74] OPEN REVERSED
;CALL+1: POPJ RETURN
;MAKE PRELIMINARY CHECKS: ALREADY OPEN, OPTIONAL FILE PRESENT,
;ANOTHER FILE USING SHARED BUFFER AREA ***OPNDEV***
C.OPEN: TXO AC16,V%OPEN ;OPEN VERB
MOVE AC0,[FS.ZRO,,FS.FS];ZERO THE ERROR
BLT AC0,FS.IF ; STATUS WORDS.
SETOM FS.IF ;IDX FILE IS DEFAULT
MOVE FLG,F.WFLG(I16)
HLLZ FLG1,D.F1(I16) ;MORE FLAGS
MOVEI AC0,AFTADV!RDLAST ;RESET SO BFR-ADV WILL NOT WRITE 'CR' FIRST
ANDCAM AC0,D.RFLG(I16) ; AND MAKE SURE VALID READ LAST VERB IS OFF
LDB AC0,F.BBLC ;[346] CHECK FLAG TO SEE IF THIS
JUMPE AC0,OOVLER ; FILE TABLE HAS BEEN LINKED TO THE CHAIN.
TLNE FLG,OPNIN+OPNOUT ;IS THE FILE OPEN?
JRST OPNFAO ;YES, ERROR
SETZM D.RP(I16) ;INITIALIZE THE RECORD SEQUENCE NUMBER
SETZM D.EXOF(I16) ; INITIALIZE THE RES SEQ OFFSET FOR SIXBIT
LDB AC5,F.BLF ;IS THE FILE IS LOCKED?
JUMPN AC5,OPNFAL ;YES, ERROR
TXNE AC16,OPN%OU ;SKIP IF NOT OUTPUT
TLO FLG,OPNOUT ;
TXNE AC16,OPN%IN ;SKIP IF NOT INPUT
TLO FLG,OPNIN ;
TLNE FLG,OPNOUT ;JUMP IF OUTPUT
JRST OPNSBA ; OUTPUT FILES ARE NOT OPTIONAL
TXNE FLG1,B%OPTF ;IS FILE OPTIONAL?
JRST OPNOP ;YES. RETURNS ONLY IF PRESENT
OPNSBA: PUSHJ PP,DEVIOW ;RESET THE DEVICE IOWD
HLRZ AC4,F.LSBA(I16) ;FILTAB THAT SHARES THE SAME BUFFER
OPNSB1: JUMPE AC4,OPNDEV ;JUMP IF NO ONE SHARES
CAIN AC4,(I16) ;HAVE WE CHECKED ALL "SBA" FILTAB'S
JRST OPNDEV ;YES
LDB AC1,[<F%BRMS>&<777760,,-1>+<Z (AC4)>] ;RMS BIT FOR THIS FILE
JUMPN AC1,OPNSB3 ; JUMP IF THIS SBA FILE IS AN RMS FILE
; NON-RMS, V12B FILES:
HLL AC4,F.WFLG(AC4) ;GET THE FLAGS
TLNE AC4,OPNIN!OPNOUT ;SKIP IF ANY FILES ARE NOT OPEN
JRST OPNSB2 ;GIVE AN ERROR MESSAGE
JRST OPNSB4 ;OK FOR THIS FILE
; RMS FILES ONLY FOR V12B,
OPNSB3: HRR AC1,D.F1(AC4) ;GET V13 STYLE FLAGS FOR THIS FILE
TXNE AC1,LF%INP!LF%OUT ;IS THIS FILE OPEN?
JRST OPNSB2 ;YES, GIVE AN ERROR MESSAGE
OPNSB4: HLRZ AC4,F.LSBA(AC4) ;GET NEXT "SBA FILTAB"
JRST OPNSB1 ;+LOOP
OPNSB2: MOVEI AC0,FE%12 ;ERROR NUMBER
PUSHJ PP,OXITP ;DOESN'T RETURN IF IGNORING ERRORS
MOVE AC5,AC4 ;MSOUT. USES AC4
MOVE AC2,[BYTE (5)10,31,20,2,1,14]
PUSHJ PP,MSOUT.
HRLZI AC2,(BYTE (5)10,31,20)
HRR AC16,AC5
JRST MSOUT. ;SOME OTHER FILE IS USING OUR BUFFER AREA
OOVLER: HRRZ AC0,HLOVL. ;[346] GET START OF OVERLAY AREA
CAIG AC0,(I16) ;[346] IF FILE-TABLE IN OVL AREA
JUMPN AC0,OOVLE1 ;[346] COMPLAIN
MOVEI AC0,FE%30 ;ERROR NUMBER
PUSHJ PP,OXITP ;POPJ TO MAIN LINE IF IGNORING ERRORS
PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ "Attempt to do I/O from a subroutine called by a non resident subroutine."] ;[346]
JRST OOVLE2 ;[346]
OOVLE1: MOVEI AC0,FE%31 ;ERROR NUMBER
PUSHJ PP,OXITP ;POPJ IF IGNORING ERRORS
PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /IO cannot be done from an overlay./] ;[346]
OOVLE2: HRLZI AC2,(BYTE (5)10,2) ;[346] GO COMPLAIN
PUSHJ PP,MSOUT. ;[346] DOESN'T RETURN
;ATTEMPT TO OPEN FILE WHICH WAS SELECTED AS OPTIONAL
OPNOP:
PUSHJ PP,OPNSBA ;ATTEMPT TO OPEN THE FILE THE USUAL WAY
SKIPN CMPTER## ;CHECK FOR ERROR - ONLY AN 05 WILL COME BACK HERE
POPJ PP, ; NONE FOUND
PUSHJ PP,$SIGN ;[277] OUTPUT "$" FOR .OPERATOR
OUTSTR [ASCIZ /Optional/] ;OPTIONAL FILE FOUND NOT TO BE PRESENT
PUSHJ PP,MSFIL.
OUTSTR [ASCIZ / is not present. Proceed? ... /]
PUSHJ PP,YES.NO ;SKIP RETURN IF "NO" ANSWER
SKIPA ;USER WANTS TO CONTINUE
PUSHJ PP,KILL ;DOESN'T WANT TO CONTINUE
TLO FLG,NOTPRS ;NO, "NOT PRESENT"
TLZ FLG,OPNIN ;NOTE THAT IT'S NOT OPEN
MOVEM FLG,F.WFLG(I16) ;%SAVE THE FLAG WORD
POPJ PP, ;RETURN TO MAIN LINE *EXIT************
YESNO: CLRBFI ;CLEAR THE BUFFER
OUTSTR [ASCIZ /$ Type YES or NO.
/]
YES.NO: MOVE AC5,[POINT 7,[ASCIZ /ES/],]
PUSHJ PP,GETCH.
JRST .-1
CAIE C,"Y"
CAIN C,"Y"+40 ;ALLOW LOWERCASE
CAIA ;LOOKS LIKE "YES" SO FAR..
JRST YESNO2 ;DIDN'T START WITH "Y", TRY "NO"
YESNO1: PUSHJ PP,GETCH.
POPJ PP, ;IS THE "YES" RETURN
ILDB AC4,AC5
JUMPE AC4,YSNOFN ;[564] [V10] YES FOUND, EAT INPUT UNTIL EOL
CAIE C,(AC4) ;IS THIS A "YES" CHARACTER?
CAIN C,40(AC4) ; CHECK LOWER-CASE CHARACTER TOO
JRST YESNO1 ;YES, KEEP CHECKING AS LONG
; AS HE SPELLED IT OUT
JRST YESNO ;NO, GO ASK AGAIN
YESNO2: MOVE AC5,[POINT 7,[ASCIZ /NO/],]
YESNO3: ILDB AC4,AC5
JUMPN AC4,YESNO4 ;[564] [V10] CHECK NEXT 'NO' CHAR,IF GOT ONE
AOS (PP) ;[564] ELSE, GIVE SKIP RETURN
YSNOFN: PUSHJ PP,GETCH. ;[564] GET ANOTHER CHAR
POPJ PP, ;[564] GOT EOL, RETURN
JRST YSNOFN ;[564] EAT CHARS UNTIL EOL
YESNO4: CAIE C,(AC4) ;SKIP IF A "NO" CHARACTER
CAIN C,40(AC4) ; CHECK LOWERCASE ALSO
CAIA ;SO FAR, SO GOOD
JRST YESNO ;?BAD INPUT, GO PROMPT AGAIN
PUSHJ PP,GETCH.
JRST RET.2 ;THE NO RETURN
JRST YESNO3
;SETUP DEVICE IOWD
DEVIOW: HRLOI AC0,77 ;
AND AC0,F.WDNM(I16) ;
TLC AC0,-1 ;
AOBJP AC0,.+1 ;
HRR AC0,F.WDNM(I16) ;
TLNE FLG,IDXFIL ;IF INDEX FILE
AOBJP AC0,.+1 ; POINT AT DATA DEVICE
MOVEM AC0,D.ICD(I16) ;
POPJ PP, ;
;GET DEVICE CHARACTERISTICS AND CHECK IF DEVICE CAN DO
;REQUESTED IO FUNCTIONS ***OPNCHN***
;ENTRY POINT FOR READ GENERATED CLOSE GENERATED OPEN. ***READEF+N***
OPNDEV: SETZM D.OE(I16) ;CLEAR NUMBER OF OUTPUTS
SETZM D.IE(I16) ; NUMBER OF INPUTS
MOVE AC13,D.ICD(I16) ;ADR OF DEV. NAME
MOVE AC13,(AC13) ;SIXBIT/DEVICE NAME/
MOVEM AC13,UOBLK.+1 ;FOR OPEN
DEVCHR AC13, ;DEVCHR UUO
TXC AC13,DV.DSK!DV.CDR ;[330] IF A DSK AND A CDR
TXCN AC13,DV.DSK!DV.CDR ;[330] THEN ITS DEVICE 'NUL'
TXZ AC13,DV.MTA!DV.TTY ;[506] SO ITS NOT A MTA OR TTY
MOVEM AC13,D.DC(I16) ;[330] SAVE THE CHARACTERISTICS
JUMPE AC13,OPNDE9 ;NOT A DEVICE
TXNN AC13,DV.AVL ;SKIP IF AVAILABLE TO JOB
JRST OPNDNA
TXNN AC13,DV.DSK ;SKIP IF A DSK
TRNN AC13,DV.ASP ;SKIP IF DEV IS INITED
JRST OPNDE5
MOVE AC2,[BYTE (5)10,2,4,20,16] ;FCBO,DIATAF.
MOVEI AC0,FE%14 ;ERROR NUMBER
JRST OXITER ;COMPLAIN
OPNDE5: TXNN AC16,OPN%EX ; OPEN EXTEND?
JRST OPNDE6 ; NO
TLNN FLG,IOFIL ; DUMP MODE FILE?
JRST OPDE5A ; NO, CONT
; YES, ERROR, RESET TIME BUFFER ALLOCATION CAUSES TROUBLE
; HERE, WANTS BOTH DUMP MODE AND RING BUFFERS
MOVEI AC0,FE%55 ; ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE THE ERROR?
JRST RCHAN ; YES
PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /Program may not have OPEN I-O and OPEN EXTEND for same file FD./]
MOVE AC2,[BYTE (5) 10,31,20,2]
PUSHJ PP,MSOUT. ;DOESN'T RETURN
OPDE5A: MOVEI AC0,EXTOPN ; YES, SET OPEN WAS EXTEND
IORM AC0,D.RFLG(I16)
TXNE AC13,DV.MTA ;MTA?
TXZ FLG1,B%STL ;YES, DON'T CREATE A NEW LABEL
OPNDE6: TLNE FLG,IOFIL ;[622] SKIP UNLESS IO TYPE FILE (DUMP MODE)
JRST OPNDE7 ;IO REQUESTED
OPND6A: TXNN AC16,OPN%EX ; OPEN EXTEND?
TLNE FLG,OPNIN ; OR INPUT ?
TXNE AC13,DV.IN ; YES,SKIP IF DEVICE CANNOT DO INPUT
JRST OPNDE8 ;NEXTEST
MOVE AC2,[BYTE (5)10,2,4,20,21]
MOVEI AC0,FE%16 ;ERROR NUMBER
JRST OXITER ;COMPLAIN
OPNDE7: TXNE AC13,DV.DSK ;SKIP IF DEVICE IS NOT A DSK
JRST OPNCHN ;FIND A FREE CHANNEL
MOVEI AC0,FS%37 ;8x FILE STATUS CODE
MOVEM AC0,FS.FS ;
MOVEI AC0,FE%15 ;ERROR NUMBER
MOVE AC2,[BYTE (5)10,2,4,20,17]
JRST OXITER ;
OPNDE8: TXNN AC16,OPN%EX ; OPEN EXTEND
TLNE FLG,OPNOUT ; OR OUTPUT?
TXNE AC13,DV.OUT ; YES,SKIP IF DEVICE CANNOT DO OUTPUT
JRST OPNCHN ; OK,FIND A FREE CHAN
MOVE AC2,[BYTE (5)10,2,4,20,22]
MOVEI AC0,FE%17 ;ERROR NUMBER
JRST OXITER ;COMPLAIN
OPNDE9: MOVE AC2,[BYTE (5)10,2,4,20,13] ;FCBO,DINAD.
MOVEI AC0,FE%18 ;ERROR NUMBER
JRST OXITER ;COMPLAIN
;FIND A FREE DEVICE CHANNEL AND SETUP THE BUFFERS
;XCT OPEN, INBUF AND/OR OUTBUF ***OPNBSI***
OPNCHN:
IFN TOPS20,<
TXNE AC13,DV.LPT ;[1120] SIMPLE OUTPUT DEVICE
JRST OPCH1A ;[1120] YES, DON'T GET CHANNEL NUMBER
>
PUSHJ PP,GCHAN ;LOAD AC5 WITH A CHANNEL NUMBER
DPB AC5,DTCN. ;SAVE IT
TLNN FLG,IDXFIL ;INDEX FILE ?
JRST OPNCH1 ;NO
PUSHJ PP,GCHAN ;
HLRZ I12,D.BL(I16) ;
HRRZM AC5,ICHAN(I12) ;SAVE INDEX FILE CHAN NO.
OPNCH1: PUSHJ PP,SETC1. ;DISTRIBUTE THE CHANNEL NUMBER
OPCH1A: TLNE FLG,DDMASC ;[1120] SKIP IF NOT ASCII
TDZA AC6,AC6 ;ASCII MODE AND SKIP
MOVEI AC6,.IOBIN ;PERHAPS BINARY
TLNE FLG,RANFIL!IOFIL!IDXFIL ;[622] SKIP IF BUFFERED IO
MOVEI AC6,.IODMP ;DUMP MODE
HRRM AC6,UOBLK. ;UOBLK.+1 SET AT DEVCHR
IFE TOPS20,<
PUSHJ PP,OPNCKP ;SEE IF WE WANT TO OPEN FILE IN CHECKPOINT MODE
>
HRLI AC6,D.OBH(I16) ;OUTPUT BUFFER HEADER
HRRI AC6,D.IBH(I16) ;INPUT BUF HDR
MOVEM AC6,UOBLK.+2
TLNN FLG,IDXFIL ;ISAM ?
JRST OPNCH3 ;NO
MOVE AC1,F.WDNM(I16) ;ADR
MOVE AC1,(AC1) ;IDX DEVICE NAME
MOVEM AC1,UOBLK.+1 ;
OPNCH3: SKIPL WANT8. ;WANT 8x FUNCT?
JRST OPNCH4 ;NO
TXNE AC13,DV.MTA ; DOING MAG-TAPE OPEN?
TXNN AC16,OPN%NR ;AND NO-REWIND BIT SET?
JRST OPNCH4 ;NO
MOVEI AC0,FS%07 ;YES GIVE FS = 7
MOVEM AC0,FS.FS ;
MOVEI AC0,FE%58 ;ERROR NUMBER
PUSHJ PP,IGCVR ;GO SET UP FS REPORT
TRN ; IGNORE ERROR RETURN
OPNCH4: SKIPE AC1,F.PADD(I16) ; DO WE NEED TO SET UP PADDING CHAR?
PUSHJ PP,SETPAD ; YES
TXNE AC16,OPN%EX ;OPEN EXTENDED?
JRST OPNC3A ; YES
IFN TOPS20,<
TXNE AC13,DV.MTA ;[1066] IF ITS NOT AN MTA
TLNE FLG1,MSTNDR ;[1066] OR MONITOR IS LABELING
JRST OPNC3C ;[1066] OPEN VIA COMPT. UUO
JRST OPNC31 ;[1066] OTHERWISE OPEN VIA FILOP.
>
IFE TOPS20,<
SKIPN F.WSMU(I16) ; SKIP IF SIMULTANEOUS UPDATE
JRST OPNC31 ; NO, CONT
JRST OPNC3A ; OPEN VIA FILOP
>
IFN TOPS20,<
OPNC3C: PUSHJ PP,OCPT ; [431] OPEN FILE VIA DEC-SYS-20 COMPT.
TRNA ;ERROR, CHECK FOR FNF
JRST OPNC41 ; CONT NORMALLY, ALL OK
TLNE FLG,IDXFIL ;IS IT AN ISAM FILE
JRST OCPER ;YES, GIVE THE ERROR
TLC FLG,OPNIN!OPNOUT
TLCE FLG,OPNIN!OPNOUT ;IF OPEN I/O
TXNN AC16,OPN%EX ;OR OPEN EXTEND
IFG ANS82,<
SKIPL WANT8. ;[1167] ITS OK, CREATE NON-EXISTENT FILE IF ANS-82 DEFAULT
>
JRST OCPER ; OTHERWISE GIVE FNF ERROR
CAIG AC1,GJFX21 ;IS IT ONE OF FILE NOT FOUND
CAIGE AC1,GJFX17
CAIN AC1,GJFX24
JRST OPNFNF ;YES FNF!!
CAIE AC1,GJFX32 ;STILL MORE FNF POSSIBILITIES
CAIN AC1,OPNX2 ;LAST ONE TO CHECK FOR
JRST OCPER ;NOT FNF, SCREW IT
OPNFNF: HRRZI AC1,GJ.BLK ;[1133]DO FILE CREATE OPEN (LONG FORM)
MOVEM AC1,CP.BK1
SETZM GJ.BLK ;[1133] TURN OFF GJ%OLD
MOVE AC1,[10,,CP.BLK]
TXNE AC16,OPN%EX ;IF OPEN EXTEND
HRLI AC1,11 ; ARG BLOCK HAS ONE MORE WORD
SETZM CMPTER## ;
;**;[1140] At OPNFNF+6L
TXNN AC16,OPN%EX ;[1140] IF OPEN EXTEND
JRST UNXTND ;[1140] ELSE SKIP
PUSH PP,.JBFF ;[1140] SAVE .JBFF
HLRZ AC11,D.BL(I16) ;[1140] PNT TO BUFFER LOCATION
MOVEM AC11,.JBFF ;[1140] SO PA1050 STARTS THERE
UNXTND: COMPT. AC1, ;DO IT
TDZA AC11,AC11 ;[1140] CLEAR FOR FAILURE
SETOI AC11, ;[1140] ELSE WE SUCCEED
TXNE AC16,OPN%EX ;[1140] OPEN EXTEND?
POP PP,.JBFF ;[1140] YES, RESTORE END-OF-CORE PNTR
SKIPN AC11 ;[1140] SKIP FOR SUCCESS
JRST [MOVEM AC1,CMPTER ;SAVE ASIDE UUO ERROR CODE
JRST OCPER] ;FAILED AGAIN, SCREW IT
TLNE FLG1,FOPIDX ; IF AN ISAM.IDX FILE GET CHAN #
SKIPA AC2,ICHAN(I12) ; FROM HERE
LDB AC2,DTCN. ; ELSE FROM HERE
PUSHJ PP,GETJFN ; GET THE JFN
SETZ AC1, ; FAILED, CANNOT HAPPEN
HRRM AC1,D.JFN(I16) ; STORE JFN
JRST OPNC41 ;GOOD CONTINUE WITH NEW FILE
>;END IFN TOPS20
OPNC3A:
IFN TOPS20,<
TXNE AC13,DV.MTA ; IF MTA STILL USE FILOP
JRST OPNC3B
LDB AC1,F.BNAB ;GET NUMBER OF BUFFERS WANTED
SKIPN AC1 ;ZERO MEANS
MOVEI AC1,DFLTBF ; USE DEFAULT NO.
HRLZM AC1,CP.BK8 ;STORE NO. OF BUFFERS
JRST OPNC3C ;USE, NEW COMPT. FUNCTION
OPNC3B:>
PUSHJ PP,OPNFOP ; [431] YES OPEN FILE VIA FILOP
JRST OFERRI ; [576] [431] ERROR RETURN
JRST OPNC41 ; CONT NORMALLY
OPNC31:
IFE TOPS20,<
TXNN AC13,DV.MTA ; SKIP IF A MTA
JRST OPC31X ; JUMP IF NOT MTA
; IF PULSAR LABEL PROCESSOR IS UP AND WE'RE NOT BYPASSING
; LABELS THEN LET PULSAR DO THE LABELING. IF BYPASS LABELS
; IS ON THEN LIBOL WILL DO LABELING AS ALWAYS.
SKIPN AUTOLB ; DO WE HAVE AUTO LABEL PROCESSING?
JRST OPC31X ; NO
PUSHJ PP,MTALAB ; GET LABEL INFORMATION (AC3 GETS LABEL TYPE)
JRST OPC31X ; NO SYS LABELS,LEAVE IT AS IT IS,
LDB AC3,F.BLBT ; GET LABEL TYPE
CAIE AC3,.TFLNL ; UNLABELED?
JRST OPC31L ; NO, SYS-LABELS, CLEAR COBOL LABELING
TLO FLG1,MTNOLB ; YES, SET IT TO INDICATE SO
HLLM FLG1,D.F1(I16) ; SAVE IT FOREVER
JRST OPC31X ; CONT
OPC31L: TXZ FLG1,B%STL ; SYS LABELS,THEN LET PULSAR DO LABELS
CAIE AC3,.TFLNS ; "NON-STANDARD"?
TLO FLG1,MSTNDR ; NO, SET MONITOR DOING LABELING
HLLM FLG1,D.F1(I16) ; SAVE IT FOREVER
TLNN FLG1,MSTNDR ; WAS THAT SYS-LABELS?
JRST OPC31X ; NO, CONT WITHOUT CHECKS
TLNE FLG,OPNOUT ; AND OPEN OUTPUT?
JRST OPC31X ; YES, CONT
; NO,CHECK INPUT LABEL
; HERE FOR OPEN INPUT
OPC31F: LDB AC1,F.BFMT ; GET LABEL FORMAT BITS
TXNE AC1,FRMATU ; "U" FORMAT?
JRST OPC31J ; YES, NO CHECKS NECESSARY
CAIE AC3,.TFLAL ; IS THE LABEL TYPE ANSI
CAIN AC3,.TFLAU ; OR ANSI WITH USER LABELS?
JRST OPC31H ; YES,JUMP
; ASSUME IBM LABELS HERE
TXNE AC1,FRMATS ; IS IT "S" FORMAT?
JRST RERE6 ; YES, ERROR SPANNED EBCDIC NOT SUPPORTED
TXNN AC1,FRMATD ; IS IT "D" FORMAT?
JRST OPC31I ; NO,CONT
JUMPL FLG1,OPC31X ; JUMP IF VARIABLE EBCDIC, OK
JRST OMTA0E ; ERROR, WRONG FORMAT FOR RECORDING MODE
; HERE IF "F" FORMAT, DDM MUST MATCH
OPC31I: JUMPL FLG1,OMTA0E ; IF VARIABLE EBCDIC, ERROR
JRST OPC31X ; ELSE OK,CONT
; HERE FOR ANSI LABELED INPUT, CHECK FORMATS
OPC31H: TXNE AC1,FRMATS+FRMATD ; IS IT "D" OR "S" FORMAT?
JRST OPC31K ; YES,ERROR JUMP
; OPEN INPUT ANSI-LABELED "F FORMAT"
; MAKE SURE COMPATIBLE DATA MODE IS SET
JUMPGE FLG,OMTA0E ; ERROR IF NOT ASCII RECORDING MODE
PUSHJ PP,CMPASC ; NO,MAKE SURE WE GET COMPATIBLE ASCII
JRST OPC31X ; CONT
; CMPASC ROUTINE TO MAKE SURE COMPATIBLE ASCII WILL BE WRITTEN
; FOR ANSI LABELED TAPES ON TOPS 10 (F FORMAT)
; RETURNS +1 ALWAYS
CMPASC: PUSHJ PP,TM03AS ; ENSURE COMPATIBLE DATA MODE
HRRZ AC0,D.RFLG(I16) ; GET RUNTIME FLAGS
TRNE AC0,INDASC ; IND-ASC?
POPJ PP, ; YES, RETURN, IND-CMP MODE SET LATER
PUSHJ PP,STDASC ; NO, SET ANSI ASCII MODE
TROA AC0,INDASC ; ERROR SET INDASC MODE AND SKIP
POPJ PP, ; OK, RETURN
HRRM AC0,D.RFLG(I16) ; RESET (IF CHANGED)
POPJ PP, ; RETURN
OPC31K: MOVX AC0,E.MTAP+FE%54 ; ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE THE ERROR?
JRST RCHAN ; YES
PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /ANSI labeled "S" and "D" format mag tape not supported./]
MOVE AC2,[BYTE (5) 10,31,20,2]
PUSHJ PP,MSOUT. ;DOESN'T RETURN
; HERE IF OPEN INP ANSI LABELED "U FORMAT"
OPC31J: HRRZ AC0,D.RFLG(I16) ; GET STANDARD ASCII FLAG
TRNN AC0,SASCII ; DOES HE WANT IT?
TRZ AC0,INDASC ; NO, CLEAR ANY INDASC SETTING DONE AT RESET
HRRM AC0,D.RFLG(I16) ; PUT IT BACK
JRST OPC31X ; CONT
OPC31X:
> ;END OF IFE TOPS20
;FOR TOPS-20 MTA DEVICES ONLY - ALL OTHERS USE COMPT. UUO OR NATIVE MODE
; AND REJOIN AT OPNC41.
PUSHJ PP,SETBM ;SET BYTE MODE IF REQUIRED
XCT UOPEN. ;OPEN THE DEVICE ***************
JRST OERRIF ;OPEN FAILED
OPNC41: PUSHJ PP,OPNWPB ;RETS LOGICAL BLOCK SIZE IN AC10, BLKFTR IN AC5
LDB AC6,F.BNAB ;NUMBER OF BUFFERS (FOR INBUF X,(AC6))
SKIPN AC6 ;ZERO MEANS
MOVEI AC6,DFLTBF ; USE DEFAULT NO.
IFE TOPS20,< ;[561]
TXNE AC13,DV.MTA ;SKIP IF NOT A MTA
> ;[561]
IFN TOPS20,<
TXNE AC13,DV.MTA ;[1066] [561] MTA??
TLNE FLG1,MSTNDR ;[1066] OR IS UNLABELED TAPE
JRST OPNC4D ;[561][1156] NO,SKIP FOLLOWING ENTER/LOOKUP
TXNE AC16,OPN%EX ; OPEN EXTEND?
JRST OPNC4D ; YES,SKIP THIS
PUSH PP,AC5 ;[561] YES,SAVE REGS
PUSH PP,AC6 ;[561]
PUSH PP,AC10 ;[561]
TLNN FLG,OPNIN ;[561] OPEN FOR INPUT?
JRST OPNC4A ;[561] NO
PUSHJ PP,OPNLID ;[561] YES,SET UP FOR LOOKUP
XCT ULKUP. ;[561] LOOKUP
JRST OLERR ;[561] ERROR IN LOOKUP
JRST OPNC4F ;[561] RESTORE AND CONT
OPNC4A: PUSHJ PP,OPNEID ;[561] SET UP FOR ENTER
XCT UENTR. ;[561] ENTER
JRST OEERR ;[561] ERROR IN ENTER
OPNC4F: POP PP,AC10 ;[561] RESTORE AC'S
POP PP,AC6 ;[561]
POP PP,AC5 ;[561]
LDB AC2,DTCN. ; GET CHANNEL NO.
PUSHJ PP,GETJFN ; GET THE JFN
SETZ AC1, ; FAILED, CANNOT HAPPEN
HRRM AC1,D.JFN(I16) ; STORE JFN
>;END IFN TOPS20
OPNC4D: TXNE AC13,DV.MTA ;[1066] [561][1156] MTA??
JUMPN AC5,OPNNSB ;[561] NON STANDARD BUFFER SETUP
OPNC4X: TLNE FLG,IDXFIL ;[561] ISAM ?
JRST OPNIDX ;YES
TLNE FLG,IOFIL+RANFIL ;[622] IOFIL=IOFILE
JRST OPNRIO ;RANDOM OR IO DUMP MODE BUFFERS
PUSH PP,.JBFF
HLRZ AC11,D.BL(I16) ;BUFFER LOCATION
MOVEM AC11,.JBFF
TXNE AC16,OPN%EX ;APPEND?
JRST OPNC45 ;YES, DO FILOP NOW
IFN TOPS20,<
TXNE FLG1,B%NIO ;NATIVE I/O?
JRST OPNC46 ;YES, BUFFER IS SETUP
>
TLNE FLG,OPNIN ;INPUT?
XCT UIBUF. ;**********
TLNE FLG,OPNOUT ;OUTPUT?
XCT UOBUF. ;**********
JRST OPNC46
OPNC45: HRLZM AC6,FOP.BN## ;SET NO. OF BUFFERS FOR OUTPUT
PUSHJ PP,OPNEXT ; DO THE APPEND OPEN
LDB AC0,F.BBKF ; GET BLOCKING FACTOR
JUMPE AC0,OPNC46 ; CONTINUE IF NOT BLOCKED
MOVEM AC0,D.RCL(I16) ; SET NUMBER RECORDS IN LOG BLOCK
MOVE AC1,ARGBK.+.RBSIZ ; GET FILE SIZE RETURNED BY FILOP
MOVE AC3,D.BPL(I16) ; GET NUMBER OF BUFFERS PER LOG-BLK
IMULI AC3,DSKBSZ ; CALC NUMBER WORDS PER LOG-BLK (FULL BLKS)
IDIVI AC1,(AC3) ; CALC NUMBER OF LOG-BLKS, LEAVING REMAINDER IN
; AC2 INDICATING THE NUMBER OF WORDS IN THE
; CURRENT LOG-BLK.
JUMPGE FLG1,OPC45A ; CONT IF NOT VARIABLE LENGTH EBCDIC
MOVEI AC3,-2(AC2) ; NUMBER OF WORDS WRITTEN IN LOG-BLK
; TAKE CARE OF POSSIBLE LAST PARTIAL WORD (-1)
; AND THE BDW (-2)
IMULI AC3,4 ; CALC NUMBER OF CHARS IN LOG-BLK
SUB AC3,D.TCPL(I16) ; CALC NUMBER OF FREE CHARS
MOVNM AC3,D.FCPL(I16) ; SET NUMBER OF CHARS LEFT IN LOG-BLK
OPC45A: IDIVI AC2,DSKBSZ ; CALC NUMBER OF FULL BUFFERS IN THIS LOG BLK
; THAT HAVE ALREADY BEEN WRITTEN (IN AC2)
MOVE AC3,D.BPL(I16) ; CALC NUMBER OF BUFFS LEFT
SUBI AC3,(AC2) ; IN THE CURRENT LOG-BLK
MOVEM AC3,D.BCL(I16) ; AND RESET
JUMPL FLG1,OPNC46 ; VAR LENGTH EBCDIC ENDS NOW
IMULI AC2,DSKBSZ ; CALC NUMBER OF WORDS OF FULL BUFFERS WRITTEN
TLNE FLG,DDMEBC!DDMASC ; IF ASCII OR IF EBCDIC
JRST OPC45B ; WE WANT THE CHARACTER CASE
MOVE AC1,D.WPR(I16) ; FOR SIXBIT AND BINARY
JRST OPC45C ; USE WORDS PER RECORD
OPC45B: MOVE AC1,D.CPR(I16) ; GET CHARS PER RECORD (INCLUDING OVERHEAD)
; ***NOTE***
; THIS WILL ASSUME THAT NOT VARIABLE LENGTH
; RECORDS IN THE BUFFERS PREVIOUS TO THIS ONE
IMUL AC2,D.BPW(I16) ; CALC CHARS IN FULL BUFFERS
OPC45C: IDIVI AC2,(AC1) ; CALC RECORDS IN FULL BUFS OF LOG-BLK
SUB AC2,D.RCL(I16) ; RESET THE
MOVNM AC2,D.RCL(I16) ; NUMBER OF RECORDS LEFT IN LOG-BLK
PUSHJ PP,EXTSCN ; SCAN THE CURRENT BUFFER TO CALC
; NUMBER OF RECORDS LEFT IN LOG-BLK
JRST OPNC46 ; AND CONTINUE
; OPNEXT ASSUMES FOP.BK SET FOR BUFFER NUMBER
; IT SETS UP AND EXECUTES THE APPEND FILOP, AND ADJUSTS
; THE BYTE COUNT FOR THE BUFFER READ IN, TO REFLECT
; THE CURRENT BYTE SIZE.
OPNEXT:
TXNN AC13,DV.MTA ; SKIP IF MAG TAPE
JRST OPNEX0 ; ELSE CONT
; HERE WE MUST CHECK FOR PROPER DENSITY, PARITY AND DATA MODE FOR
; THE APPEND FILOP.
LDB AC0,F.BPAR ; GET THE PARITY INDICATED IN THE PROGRAM
DPB AC0,[POINT 1,FOP.IS,26] ; SET IT IN THE FILOP. STATUS FIELD
LDB AC0,F.BDNS ; GET DENSITY INDICATED BY PROGRAM
IFN TOPS20,<
; FOR THE 20 GET DEFAULT TAPE SETTINGS AND CHECK AGAINST REQUESTED
PUSHJ PP,GTDFLT ; GET DEFAULT DATA MODE IN AC3
MOVE AC4,AC3 ; SAVE DATA MODE
SETO AC1, ; AC1=-1, THIS JOB
HRROI AC2,3 ; DENSITY AT AC3
MOVEI AC3,.JIDEN ; START BLOCK AT THE DEFAULT DEN WORD
GETJI% ; GET THE DENSITY
JRST KILL. ; ASSUME IT WORKS, SHOULD ALWAYS
CAIGE AC0,.TFD16 ; IS REQUESTED DEN 1600 OR GTR ?
JRST EXTMT0 ; NO, SET IN STATUS FIELD
CAIN AC0,(AC3) ; IS DEFAULT SAME AS REQUESTED?
JRST EXTMT1 ; YES, GO CHECK DATA MODE
>;END IFN TOPS20
IFE TOPS20,<
; FOR THE 10 CHECK FOR CONTROLLERS THAT READ DENISTY. IF NOT
; THEN CHECK DEFAULT SETTING
CAIGE AC0,.TFD16 ; IS REQUESTED DEN 1600 OR GTR ?
JRST EXTMT0 ; NO, SET IN STATUS FIELD
MOVE AC1,[2,,2] ; 2 ARGS START AT AC2
MOVEI AC2,.TFKTP ; GET CONTROLLER TYPE
MOVE AC3,UOBLK.+1 ; GET DEVICE NAME
TAPOP. AC1, ; GET CONTROLLER TYPE INTO AC1
JRST EXTPER ; ERROR IN TAPOP.
CAIE AC1,.TFKTX ; TX01
CAIN AC1,.TFKD2 ; OR DX20/TX02?
JRST EXTMT1 ; YES, DENSITY IS READ FROM TAPE
; NO,CHECK DEFAULT DENISTY SETTING
MOVE AC1,[3,,2] ; 3 ARGS START AT AC2
MOVEI AC2,.TFDEN+.TFSET ; SET TAPE DENSITY
SETZ AC4, ; SET TO UNIT DEFAULT
TAPOP. AC1, ; SET THE DENSITY
JRST EXTPER ; FILOP ERROR
MOVE AC1,[2,,2] ; 2 ARGS START AT AC2
MOVEI AC2,.TFDEN ; DENSITY AGAIN
TAPOP. AC1, ; GET THE UNIT DEFAULT
JRST EXTPER ; TAPOP. ERROR
CAIN AC0,(AC1) ; IS DEFAULT THE REQUESTED?
JRST EXTMT1 ; YES, GO CHECK DATA MODE
>;END IFE TOPS20
; HERE IF DENSITY CAN'T BE SET FOR THE APPEND FILOP.
POP PP,(PP) ; DISCARD OPNEXT POPJ
LDB AC0,F.BBKF ; GET BLOCKING FACTOR
JUMPN AC0,.+2 ; SKIP IF BLOCKED
POP PP,(PP) ; DISCARD .JBFF SAV
MOVEI AC0,FE%49 ; ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE THE ERROR?
JRST RCHAN ; YES
PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /Unable to set requested density for OPEN EXTEND./]
MOVE AC2,[BYTE (5) 10,31,20,2]
PUSHJ PP,MSOUT. ;DOESN'T RETURN
IFE TOPS20,<
; HERE WITH TAPOP. ERROR
EXTPER:
POP PP,(PP) ; DISCARD OPNEXT POPJ
LDB AC0,F.BBKF ; GET BLOCKING FACTOR
JUMPN AC0,.+2 ; SKIP IF BLOCKED
POP PP,(PP) ; DISCARD .JBFF SAV
MOVX AC0,E.MTAP+FE%50 ; ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE THE ERROR?
JRST RCHAN ; YES
PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /TAPOP. error processing OPEN EXTEND for mag tape./]
MOVE AC2,[BYTE (5) 10,31,20,2]
PUSHJ PP,MSOUT. ;DOESN'T RETURN
>;END IFE TOPS20
; HERE TO SET DENSITY IN STATUS FIELD
EXTMT0: DPB AC0,[POINT 2,FOP.IS,28] ; DENSITY IN STATUS BITS
; HERE TO CHECK THAT DATA MODE IS PROPER
EXTMT1:
IFE TOPS20,<
PUSH PP,D.OBH(I16) ; SAVE OUT BUFF HEADER
PUSH PP,D.OBB(I16) ; SAVE OUT BUFF PTR
XCT UOPEN. ; OPEN THE DEVICE
JRST [ POP PP,AC0 ; THROW OUT BUFF
POP PP,AC0 ; HEADER AND PTR
JRST OERRIF] ; ERROR
MOVE AC1,[2,,2] ; 2 ARGS START AT AC2
MOVEI AC2,.TFMOD ; DATA MOD FUNCTION
MOVE AC3,UOBLK.+1 ; DEVICE NAME
TAPOP. AC1, ; GET DEFAULT DEVICE DATA MODE
JRST [ POP PP,AC0 ; THROW OUT BUFF
POP PP,AC0 ; HEADER AND PTR
JRST EXTPER] ; TAPOP. ERROR
XCT UCLOS. ; CLOSE IT FOR APPEND FILOP.
XCT URELE. ; RELEASE IT TOO (WACHS SAYS SO)
POP PP,D.OBB(I16) ; RESTORE BUFF PTR
POP PP,D.OBH(I16) ; AND HEADER
>;END IFE TOPS20
TLNN FLG,DDMEBC ; SKIP IF DEVICE MODE EBCDIC
JRST EXTMT2 ; ELSE GO ON
IFE TOPS20,<
CAIE AC1,.TFM8B ; IS DEFAULT MODE INDUSTRY COMPATIBLE
JRST EXTDER ; NO, ERROR
JRST OPNEX0 ; YES, ALL OK, GO DO FILOP.
>;END IFE TOPS20
IFN TOPS20,<
CAIE AC4,.SJDM8 ; IS DEFAULT MODE INDUSTRY COMPATIBLE?
JRST EXTDER ; NO, ERROR
JRST OPNEX0 ; YES, ALL OK, GO DO FILOP.
>;END IFN TOPS20
; NOT EBCDIC IS IT ANSI ACSII ?
EXTMT2: HRRZ AC0,D.RFLG(I16) ; GET STANDARD ASCII FLAG
TRNN AC0,SASCII ; DOES HE WANT IT?
JRST OPNEX0 ; NO, ALL OK GO DO FILOP.
IFE TOPS20,<
CAIE AC1,.TFM7B ; IS DEFAULT MODE ANSI ASCII ?
JRST EXTDER ; NO, ERROR
JRST OPNEX0 ; YES, ALL OK CONT
>; END IFE TOPS20
IFN TOPS20,<
CAIE AC4,.SJDMA ; IS DEFAULT MODE ANSI ASCII ?
JRST EXTDER ; NO, ERROR
JRST OPNEX0 ; YES, ALL OK CONT
>; END IFN TOPS20
; HERE IF DATA MODE CAN'T BE SET
EXTDER: POP PP,(PP) ; DISCARD OPNEXT POPJ
LDB AC0,F.BBKF ; GET BLOCKING FACTOR
JUMPN AC0,.+2 ; SKIP IF BLOCKED
POP PP,(PP) ; DISCARD .JBFF SAV
MOVEI AC0,FE%51 ; ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE THE ERROR?
JRST RCHAN ; YES
PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /Unable to set requested data mode for OPEN EXTEND./]
MOVE AC2,[BYTE (5) 10,31,20,2]
PUSHJ PP,MSOUT. ;DOESN'T RETURN
OPNEX0: MOVE AC1,UOBLK.+2 ;GET BUFFER HEADERS
MOVEM AC1,FOP.BH## ;STORE IN FILOP. BLOCK
IFN TOPS20,<
TXNN AC13,DV.MTA ;IF NOT MTA
JRST OPNEX5 ;ITS ALREADY OPENED VIA COMPT. UUO
>
SETZM D.OBB(I16) ;[1026] ZERO BUFFER POINTER
MOVE AC1,[7,,FOP.BK]
FILOP. AC1,
JRST [POP PP,(PP) ; DISCARD OPNEXT RETURN
LDB AC0,F.BBKF ; GET BLOCKING FACTOR
SKIPE AC0 ;[1042] SKIP IF NOT BLOCKED
TLNN FLG,IOFIL!RANFIL!IDXFIL ;[1042] SEQUENTIAL FILE?
POP PP,(PP) ;[1042] YES, DISCARD .JBFF SAV
JRST OFERR] ; FAILED
OPNEX5: JUMPL FLG,OPNEX1 ;JUMP IF ASCII
TLNE FLG,DDMBIN
POPJ PP, ;DON'T CHANGE IF BINARY
HLRZ AC6,FOP.BH ;GET OUTPUT BUFFER HEADER
TLNN FLG,DDMEBC
JRST OPNEXS ; SIXBIT, CONTINUE
MOVEI AC1,9 ; EBCDIC
TXNE AC13,DV.MTA ; SKIP IF NOT MTA
IFN TOPS20,<
MOVEI AC1,8 ; ELSE IT IS INDUSTRY COMPATIBLE
>
IFE TOPS20,<
JRST EX10ER ; EBCIDC TAPE EXTEND NOT SUPPORTED ON 10
>
DPB AC1,[POINT 6,1(AC6),11] ; RESET BYTE SIZE
MOVEI AC1,4 ;
IMULM AC1,2(AC6) ;ADJUST BYTE COUNT
IFE TOPS20,<
EX10ER: PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /OPEN EXTEND for EBCDIC tapes currently not supported./]
MOVE AC2,[BYTE (5)10,31,20,2] ; FILENAME AND DEVICE MESSAGE AND KILL
PUSHJ PP,MSOUT.
>
; RESET THE BYTE PTR TO FIRST FREE CHAR
OPNEX1:
;BL; INSERTED AT OPNEX1 TO FIX OPEN-EXTEND BUG
HRRZ AC4,D.OBB(I16) ;GOOD DEST ADDR IN BPTR?
JUMPE AC4,OPNEXX ; NO, WAIT FOR DUMMYOUT
SOS AC1,D.OBB(I16) ; GET BUF BYT PTR
HRRZ AC2,D.OBH(I16) ; GET ADDR OF BUF HEADER
CAIE AC2,(AC1) ; BYT PTR AT BUF BEGINING?
JRST OPNX1A ; NO
AOS D.OBB(I16) ; YES, RESET BYT PTR
OPNEXX: POPJ PP, ; , THEN ALL SET, RETURN
OPNX1A: HRRZ AC2,D.BPW(I16) ; GET BYTS PER WORD
ADDI AC2,1 ; SET BYT COUNT RIGHT FOR LOOP
; SCAN THRU LAST DATA WORD FOR FIRST NULL CHAR
OPNEX2: MOVE AC3,AC1 ; SAVE CURRENT POSITION
SOJE AC2,OPNEX3 ; END SCAN IF NO CHARS LEFT
ILDB AC0,AC1 ; GET CHAR
JUMPN AC0,OPNEX2 ; END SCAN IF NULL FOUND
MOVE AC1,AC3 ; RESET PTR TO WRITE OVER NULL FOUND
OPNEX3: ADDM AC2,D.OBC(I16) ; ADD PARTIAL WORDS CHARS TO AVAILABLE COUNT
MOVEM AC1,D.OBB(I16) ; RESET OUT BUF BYT PTR (IF NO NULL,UNCHANGED)
POPJ PP, ; RETURN, ALL DONE
; THE SIXBIT CASE
OPNEXS: MOVEI AC1,6 ;ASSUME SIXBIT
DPB AC1,[POINT 6,1(AC6),11] ;RESET BYTE SIZE
IMULM AC1,2(AC6) ;ADJUST BYTE COUNT
POPJ PP, ; END NOW,SIXBIT IS WORD ALLIGNED
OPNC46:
HLRZ AC2,F.LSBA(I16) ;[507] FILTAB THAT SHARES SAME BUFFER
TXNN AC16,OPN%EX ;[1164] OPEN EXTEND?
JUMPN AC2,ZROBUF ;[507] CLEAR ANY POSSIBLE PREVIOUS JUNK
POP PP,.JBFF ;RESTORE .JBFF
OPNCH2: TLNN FLG,IDXFIL!RANFIL!OPNIN ;[622]
TLNN FLG,OPNOUT ;TEST FOR SEQ. OUTPUT
JRST OPNC21 ;NO
LDB AC6,[F%BLCR] ;LINAGE-COUNTER WANTED?
SKIPE AC6 ;NO
MOVEI AC6,1 ;YES, SET TO 1
MOVEM AC6,D.LCV(I16) ;SET VALUE
OPNC21: TXNE AC13,DV.DIR ;SKIP IF NON-DIRECTORY DEVICE
TXNE FLG1,B%STL ;SKIP IF NOT STANDARD LABELS
JRST OPNBSI ;SET THE BYTE SIZE
TXNE AC13,DV.CDR ;[531] IF DIRECTORY AND CDR
JRST OPNBSI ; THEN ITS NUL: WHICH IS OK
PUSHJ PP,RCHAN ;RELEASE DEVICE AND CHANNEL
MOVEI AC0,FE%19 ;ERROR NUMBER
PUSHJ PP,OXITP ;RETURN TO CBL-PRG IF IGNORING ERRORS
MOVE AC2,[BYTE (5)10,2,4,26] ;FCBO,DDMHSL
JRST MSOUT.
;[507] ZERO BUFFERED I/O BUFFER AREA.
ZROBUF: HLRZ AC3,D.BL(I16) ;[507] ORIGINAL BUFFER LOCATION
MOVE AC1,AC3 ;[507] SET UP FOR LOOP
ZRBUF2: SETZM (AC1) ;[507] INITIALIZE FILE STATUS
HLRZ AC2,1(AC1) ;[507] SIZE OF DATA BUFFER ( +1 )
HRRZ AC4,1(AC1) ;[507] ADDR 2ND WORD NEXT BUFFER
HRRZI AC1,2(AC1) ;[507] 3RD WORD OF HEADER
SETZM (AC1) ;[507] THE ZERO
ADDI AC2,-1(AC1) ;[507] UNTIL...
HRLS AC1 ;[507] FROM...
ADDI AC1,1 ;[507] TO...
BLT AC1,(AC2) ;[507] CLEAR THE BUFFER
HRRZI AC1,-1(AC4) ;[507] TOP OF NEXT BUFFER
CAME AC3,AC1 ;[507] AT BEGINNING OF RING?
JRST ZRBUF2 ;[507] NO, LOOP
POP PP,.JBFF ;[507] RESTORE
JRST OPNCH2 ;[507] CONTINUE
;SET UP NON-STD MTA BUFFERS (SIZE OF LOGICAL BLOCK). ***OPNCH2***
OPNNSB: TXNE FLG1,B%STL ;SKIP IF OMITTED LABELS
HRRZ AC10,D.LRS(I16) ;IN CASE LABEL IS GE TO REC AREA
HLRZ AC4,D.BL(I16) ;BUFFER LOCATION
ADDI AC4,1 ;BUF1+1
HRLI AC4,(BF.VBR) ; AND NEVER WAS REFERENCED
MOVEM AC4,D.IBH(I16) ;INPUT HEADER
MOVEM AC4,D.OBH(I16) ;OUTPUT HEADER
HRR AC2,AC4 ;BUF1+1
HRLI AC2,1(AC10) ;SIZE+1,,BUF1+1
SKIPA AC3,AC4 ;BUF1+1
OPNNS1: ADDI AC3,3(AC10) ;LOCATION OF NEXT LINK
ADDI AC2,3(AC10) ;SIZE+2,,<BUF1+1+SIZE+3>
MOVEM AC2,(AC3) ;SIZE+2,,BUF2+1
SOJG AC6,OPNNS1 ;LOOP IF ANY MORE BUFFERS
HRRM AC4,(AC3) ;LAST BUFFER CLOSES THE RING (BUF1+1)
ADDI AC4,1 ;BUF1+2
HRRM AC4,D.IBB(I16) ;INPUT HEADER BYTE POINTER
HRRM AC4,D.OBB(I16) ;OUTPUT H...
TXNN AC16,OPN%EX ;APPEND?
JRST OPNCH2 ;NO
SETZM FOP.BN ;DON'T CHANGE BUFFER ALLOCATION
PUSHJ PP,OPNEXT ; GO OPEN VIA APPEND FILOP
LDB AC0,F.BBKF ; GET BLOCKING FACTOR
MOVEM AC0,D.RCL(I16) ; SET NUMBER RECORDS IN LOG BLOCK
MOVE AC3,D.BPL(I16) ; GET NUMBER OF BUFFS PER LOG-BLK
MOVEM AC3,D.BCL(I16) ; AND RESET IT
PUSHJ PP,EXTSCN ; SCAN THE CURRENT BLOCK TO CALC THE NUMBER OF
; RECORDS LEFT IN THE LOGICAL BLOCK
JRST OPNCH2 ; CONTINUE AT MAIN LINE
; NOW MUST SCAN FROM BEGINING OF BLOCK TO CALC HOW
; MANY RECORDS HAVE BEEN WRITTEN SO FAR.
; THE NUMBER OF RECORDS LEFT IN THE LOGICAL BLOCK (D.RCL) HAS
; BEEN RESET TO INDICATE THE NUMBER OF RECORDS LEFT AT THE BEGINING
; OF THE CURRENT BLOCK.
EXTSCN: HRRZ AC1,D.OBB(I16) ; GET ADDR NEW WRITE POSITION
HRRZ AC2,D.OBH(I16) ; CALC ADDR OF START
ADDI AC2,1 ; OF DATA
SUB AC1,AC2 ; CALC NUMBER OF WORDS OF DATA IN BUFFER
JUMPLE AC1,OPNNXX ; EXIT IF BUFFER EMPTY
JUMPGE FLG,OPNNXS ; JUMP IF NOT ASCII
HRLI AC2,000700 ; SET UP 7-BIT BYTE PTR
; AC2 ADDR SET TO WORD BEFORE DATA ABOVE
OPNXA1: SOJLE AC1,OPNNXX ; JUMP IF SCAN COMPLETE
ILDB AC3,AC2 ; GET A CHAR
CAIL AC3,40 ; SKIP IF NOT "REAL" DATA CHAR
JRST OPNXA2 ; ELSE WE HAVE FOUND THE START OF A RECORD
MOVE AC3,CHTAB(AC3) ; GET CONVERSION TABLE ENTRY (NEG IF IGNORE CHR)
JUMPLE AC3,OPNXA1 ; JUMP IF CHAR TO BE IGNORED
OPNXA2: SOS D.RCL(I16) ; NOW DECREMENT AVAILABLE RECORDS IN BLOCK COUNT
; SCAN TO END OF RECORD
OPNXA3: SOJE AC1,OPNNXX ; JUMP IF REACHED NEW WRITE POSITION
ILDB AC3,AC2 ; GET CHAR
CAIL AC3,40 ; SKIP IF NOT "REAL" DATA CHAR
JRST OPNXA3 ; ELSE CONTINUE WITH RECORD SCAN
MOVE AC3,CHTAB(AC3) ; GET CONVERSION TABLE ENTRY (NEG IF IGNORE CHR)
JUMPGE AC3,OPNXA1 ; JUMP IF CHAR IS PART OF RECORD
JRST OPNXA1 ; CONTINUE SCAN THRU BLOCK
; HERE FOR NON-ASCII CASES
OPNNXS: TLNE FLG,DDMSIX ; SKIP IF DEVICE MODE SIXBIT
TXNN AC13,DV.MTA ; AND IF A MTA
JRST OPNNXE ; ELSE CHECK FOR EBCDIC OR BINARY
AOS AC1,AC2 ; AC2 WAS SET TO WORD BEFORE DATA ABOVE
; ADDRESS FIRST DATA WORD
HRRZ AC0,D.OBB(I16) ; GET ADDR LAST DATA WORD
CAIG AC0,(AC1) ; SKIP IF NOT EMPTY BUFFER
JRST OPNNXX ; ELSE NOTHING TO UPDATE
; SCAN DOWN SIXBIT RECORD COUNTING RECORDS
OPNXS1: CAIL AC0,(AC1) ; SKIP IF MORE TO SCAN
JRST OPNNXX ; ELSE DONE
SOS D.RCL(I16) ; DECREMENT RECORDS LEFT IN BLOCK
HLRZ AC2,(AC1) ; GET RECORD SEQ NUMBER
MOVEM AC2,D.RP(I16) ; RESET REC SEQ NUMBER FOR WRITING
HRRZ AC2,(AC1) ; GET RECORD SIZE
JUMPN AC2,.+2 ; SKIP IF NOT NULL RECORD
AOJA AC1,OPNXS1 ; ELSE ADVANCE, NULL 6-BIT IS ONE WORD
; IN THE RANDOM FORMAT
; THIS WILL NOT WORK CORRECTLY FOR THE SEQ CASE
IDIVI AC2,6 ; CALC NUMBER WORDS
JUMPE AC3,.+2 ; IN THE
ADDI AC2,1 ; RECORD
ADDI AC1,(AC2) ; ADVANCE TO NEXT RECORD
JRST OPNXS1 ; CONTINUE TO SCAN BLOCK
; HERE FOR EBCDIC AND BINARY CASES
OPNNXE: JUMPL FLG1,OPNNXV ; JUMP IF VARIABLE LENGTH EBCDIC
; HERE IF DSK SIXBIT AND, DSK OR MTA
; BINARY OR FIXED LENGTH EBCDIC, CALCULATE NUMBER
; OF RECORDS TO CURRENT POSITION
; TLNE FLG,DDMBIN ; IS DEVICE MODE BINARY?
TLNE FLG,DDMBIN!DDMSIX ;[1052]IS DEVICE MODE BINARY OR SIXBIT?
JRST OPNNXB ; YES, SET UP FOR WORDS
IMUL AC1,D.BPW(I16) ; CALC NUMBER OF BYTES DATA ON BUFFER
LDB AC2,F.BMRS ; GET MAX RECORD SIZE
OPNXE2: IDIVI AC1,(AC2) ; CALC NUMER OF MAX RECORDS IN BUFFER
JUMPE AC2,OPNXE1 ; SOME LEFT OVER ?
TXNN AC13,DV.MTA ; YES, MTA??
ADDI AC1,1 ; NO, ROUND UP FOR PARTIAL RECORD
OPNXE1: SUB AC1,D.RCL(I16) ; AC1=-(NUMBER RECORDS LEFT IN BUFFER)
MOVNM AC1,D.RCL(I16) ; RESET NUMBER OF RECORDS LEFT IN BUFFER
JRST OPNNXX ; ALL FINISHED CONTINUE
; BINARY CASE MUST BE DONE USING THE WORD NUMBERS
OPNNXB: HRRZ AC2,D.WPR(I16) ; GET REC SIZE IN WORDS
JRST OPNXE2 ; GO DO CALC WITH AC1 AND AC2 WORDS
; FOR VARIABLE LENGTH EBCIDC WE MUST CHAIN DOWN THE RDWS
; COUNTING THE RECORDS SEEN
OPNNXV: MOVE AC1,D.OBC(I16) ; GET NUMBER AVAILABLE CHARS
MOVEM AC1,D.FCPL(I16) ; RESET NUMBER FREE CHARS IN LOG-BLK
POPJ PP, ; RETURN, ALL DONE
; ALL DONE WITH BUFFER SCAN, IF BUFFER FULL, WRITE IT OUT
; AND SET UP FOR NEXT ONE
OPNNXX: SKIPE D.RP(I16) ; SKIP IF NO SIXBIT REC SEQ NUMBER SET
AOS D.RP(I16) ; ELSE SET SO IT WILL START ONE GTR THAN LAST
SKIPLE D.RCL(I16) ; SKIP IF NO RECORDS LEFT IN BLOCK
POPJ PP, ; ELSE BACK TO MAIN LINE, ALL DONE HERE
PUSHJ PP,WRTOUT ; ADVANCE BUFFERS
LDB AC0,F.BBKF ; GET BLOCKING FACTOR
MOVEM AC0,D.RCL(I16) ; RESET NUMBER RECORDS IN LOG BLOCK
MOVE AC0,D.BPL(I16) ;[1055] GET # OF BUFFERS PER LOGICAL BLOCK
MOVEM AC0,D.BCL(I16) ;[1055] RESET # OF BUFFERS TO FILL CURR LOG BLK
POPJ PP, ;RETURN TO MAIN LINE
;AC10 = WORDS PER LOGICAL BLOCK
;INITIALIZE DUMP MODE BUFFERS FOR RANDOM AND IO. ***OPNCON***
OPNRIO: HLRZ I12,D.BL(I16) ;BUFFER LOCATION
MOVE AC6,AC10 ;GET WDS/LBLK
TRZE AC6,DSKMSK ;FILL TO DISK BLK SIZE,
ADDI AC6,DSKBSZ ;ROUNDING UP IF NECESSARY
MOVN AC6,AC6 ;GET 0,,-N
HRLI AC6,R.DLRW(I12) ;LOC-1,,-N
MOVSM AC6,R.IOWD(I12) ;-N,,LOC-1
SETZM R.TERM(I12) ;IOWD TERMINATOR
SETZM R.DATA(I12) ;NO ACTIVE DATA IN BUFFER
SETZM R.BPLR(I12) ;NO INPUTS DONE FOR THIS FILE
SETOM R.WRIT(I12) ;LAST UUO WAS A WRITE
LDB AC6,[POINT 2,FLG,2] ; GET DEVICE DATA MODE
HLL AC6,RBPTB1(AC6) ; AND BYTE-POINTER
SETZM R.DLRW(I12) ; CLEAR DEL/RWT SAVE BLK NUM
HRRI AC6,1+R.DLRW(I12);FIRST DATA WORD
TXNE FLG1,B%VLER ; IF VAR-LEN EBCDIC RECORDS
ADDI AC6,1 ; SKIP OVER THE BLOCK-DESCRIPTOR-WORD
MOVEM AC6,R.BPNR(I12) ; NEXT RECORD
MOVEM AC6,R.BPFR(I12) ;BYTE POINTER TO THE FIRST RECORD
HLRZ AC2,F.LSBA(I16) ;[507] FILTAB THAT SHARES SAME BUFFER
SKIPE AC2 ;[507] SHARES BUFFER?
PUSHJ PP,ZDMBUF ;[507] YES, CLEAR IT
JRST OPNCON ;RET
;SETUP INDEX FILE BUFFER AND TABLE AREAS
OPNIDX: SETZM USOBJ(I12) ;[377] CLEAR THE FIRST WORD OF INDEX TABLE
HRRI AC0,USOBJ+1(I12);TO
HRLI AC0,USOBJ(I12) ;FROM,,TO
HRRZI AC1,ITABL-15+ICHAN(I12) ;UNTIL
BLT AC0,(AC1) ;CLEAR REST OF INDEX TABLE
HRLZ AC0,D.IBL(I16) ; [377] SEE IF WE HAVE A SAVE AREA
JUMPE AC0,OPNIX1 ; [377] NO- GO ON
HRRI AC0,ISCLR1(I12) ; [377] SET UP TO
HRRZI AC1,ISCLR2(I12) ; [377] MOVE ISAM SAVE AREA TO
BLT AC0,(AC1) ; [377] TO SHARED BUFFER AREA
OPNIX1: PUSHJ PP,OPNLIX ;INDEX FILE-NAME TO LOOKUP BLOCK
IFN TOPS20,<
; TLNN FLG,OPNOUT ;[1007] [667] IF OPEN READ ONLY OR
; JRST OPNIX2 ;DISK IS ALWAYS OPENED VIA COMPT. UUO
>
IFE TOPS20,<
SKIPE F.WSMU(I16) ; SIMULTANEOUS UPDATE?
JRST OPNIX2 ; YES
XCT ULKUP. ;LOOKUP
JRST OLERRI ;LOOKUP AND(OR) COMPT. FAILED
>
OPNIX2: TLNN FLG,OPNOUT ;OPEN FOR UPDATING?
JRST OPNI01 ;NO
OPNI00: TLO FLG1,EIX ;ENTER OF .IDX FILE IN PROGRESS
PUSHJ PP,OPNEIX ;INDEX FILE-NAME TO ENTER BLOCK
IFE TOPS20,<
SKIPE F.WSMU(I16) ; SIMULTANEOUS UPDATE?
JRST OPNIX3 ; YES
XCT UENTR. ;ENTER, FOR UPDATING
JRST OEERRI ;ENTER FAILED
>
OPNIX3: TLZ FLG1,EIX ;FREE THIS BIT FOR "RIVK" FLAG
OPNI01: HRLZI AC1,STABL ;STATISTICS BLOCK LEN
MOVNS AC1 ;
HRR AC1,I12 ;
SUBI AC1,1 ;DUMP MODE IOWD
MOVEM AC1,IOWRD+14(I12) ;SAVE IN IOWRD TABLE
SETZ AC2, ;TERMINATOR
MOVEI AC0,1 ;
HRRM AC0,UIN. ;
IFN ISTKS,<AOS INSSSS+14(I12)>
XCT UIN. ;READ THE STATISTICS BLOCK
JRST OPNI02 ;
PUSHJ PP,SETIC ;[1202]SET UP IGETS CHANNEL NUMBER
MOVX AC0,E.MINP+E.FIDX+E.BSTS ;ERROR NUMBER
PUSHJ PP,IGMIR ;IGNORE THE ERROR?
JRST RCHAN ;YES - RELEASE THE IO CHANNELS
OUTSTR [ASCIZ /OPEN failed - cannot read statistics block./]
JRST IINER
;OPEN THE DATA FILE
OPNI02: HLLZS UIN. ;CLEAR THE IOWR POINTER
MOVEI AC0,.IODMP ;DUMP MODE
HRRM AC0,UOBLK. ;SETUP OPEN BLOCK
IFE TOPS20,<
PUSHJ PP,OPNCKP ;SEE IF WE WANT TO OPEN FILE IN CHECKPOINT MODE
>
MOVE AC1,F.WDNM(I16) ;
MOVE AC1,1(AC1) ;[522] GET STRUCTURE
MOVEM AC1,UOBLK.+1 ;
SETZM UOBLK.+2 ;
PUSHJ PP,SETCN. ;SET DATA FILE CHANNEL
IFN TOPS20,<
; SKIPN F.WSMU(I16) ; SIMULTANEOUS UPDATE?
; TLNN FLG,OPNOUT ;[1007] [667] OR OPEN READ ONLY
; TRNA ;[667] YES
; JRST OPNI21 ; NO
PUSHJ PP,OCPTD ; [431] OPEN FILE VIA DEC-SYS-20 COMPT.
JRST OCPERI ; [431] ERROR RETURN
; JRST OPNI22 ; SKIP THE OPEN UUO
>
IFE TOPS20,<
SKIPN F.WSMU(I16) ; SIMULTANEOUS UPDATE?
JRST OPNI21 ; NO
PUSHJ PP,OPNFPD ; [431] OPEN FILE VIA FILOP UUO
JRST OFERR ; [576] [431] ERROR RETURN
JRST OPNI22 ; SKIP THE OPEN UUO
OPNI21: XCT UOPEN. ;OPEN THE DATA FILE
JRST OERRDF ;ERROR RETURN
>; [431] END IFE TOPS20
;SETUP IOWRD TABLE
; Set record area length for START
OPNI22: LDB AC1,F.BMRS ; Get record size
LDB AC3,[POINT 2,FLG,14] ; Get internal mode
HRRZ AC3,RBPTBL(AC3) ; Get bytes per internal record word
IDIVI AC1,(AC3) ; Get words in record area
SKIPE AC2 ; Skip if no round up
ADDI AC1,1 ; Round up
MOVEM AC1,RCARSZ(I12) ; Save for START checks
MOVEI AC3,BA(I12) ;
MOVE AC1,ISPB(I12) ;SECTORS PER BLOCK
IMULI AC1,200 ;WORDS PER SECTOR
MOVN AC2,AC1 ;-LEN
HRLZS AC2 ;-LEN,,0
HRRI AC2,-1(AC3) ;IOWD, -LEN,,LOC-1
MOVE AC4,OMXLVL(I12) ;[442] USE ORIGINAL # OF INDEX LEVELS
;[V10] SKIPN CORE0(I12) ; SKIP IF NOT FIRST OPEN FOR THIS FILE
SUBI AC4,1 ;PLUS ONE FOR SPLITTING THE TOP LEVEL
HRLZS AC4 ;
HRRI AC4,IOWRD+1(I12) ;
SKIPN (AC4) ;IF IOWRD'S ALREADY SETUP
MOVEM AC2,(AC4) ;
ADD AC2,AC1 ;
AOBJN AC4,.-3 ;LOOP
MOVN AC5,MXLVL(I12) ;SEE IF ANY NEW INDEX LEVELS WERE
SUB AC5,OMXLVL(I12) ; CREATED SINCE LAST TIME FILE WAS OPEN
JUMPGE AC5,OPNI06 ;[504] SKIP THE FOLLOWING IF NOT
HRL AC4,AC5 ;NEW LEVEL(S)
HRRZ AC5,ISPB(I12) ;[306] SECTORS PER BLOCK
IMULI AC5,200 ;[306] WORDS PER SECTOR
MOVN AC6,AC5 ;[306] NEGATE THE LENGTH
HRLZS AC6 ;[306] -LENGTH,,0
HRR AC6,.JBFF ; SO MAKE
SUBI AC6,1 ; ANOTHER IOWD
OPNI03: SKIPE (AC4) ;USE ONLY IF
JRST OPNI04 ; ANOTHER JOB MADE THE NEW LEVEL
SKIPE KEYCV. ;ARE WE SORTING?
JRST OPNIR0 ;YES - CANT HANDLE THAT
HRRZ AC0,AC5 ;[306] SET UP AC0
PUSHJ PP,GETSPC ;GET MORE CORE
JRST OPNIR1 ;TOO BAD
HRRZ AC0,HLOVL. ;DOES THE SPACE WE GOT
CAMGE AC0,.JBFF ; EXTEND INTO THE OVL-AREA?
JUMPN AC0,WOVLR1 ;GO COMPLAIN IF IT DOES
MOVEM AC6,(AC4) ;USE IT
ADD AC6,AC1 ;SET UP FOR NEXT IOWD
OPNI04: AOBJN AC4,OPNI03 ;LOOP IF YOU MUST
OPNI06: SKIPN IOWRD+13(I12) ; SKIP IF ALREADY DONE
MOVEM AC2,IOWRD+13(I12);SAT BLOCK
ADD AC2,AC1 ;
;IOWRD0, USOBJ0, CNTRY0, NNTRY0 - SET TO INDEX ON LVL
HRLZI AC0,LVL ;HOLDS CURRENT LEVEL OF INDEX
HRRI AC0,IOWRD(I12) ;
MOVEM AC0,IOWRD0(I12) ;
HRRI AC0,USOBJ(I12) ;
MOVEM AC0,USOBJ0(I12) ;
HRRI AC0,CNTRY(I12) ;
MOVEM AC0,CNTRY0(I12) ;
HRRI AC0,NNTRY(I12) ;
MOVEM AC0,NNTRY0(I12) ;
;SET BRISK FLAG OUTPUT ONLY WHEN YOU MUST
LDB AC5,F.BDIO ;GET DEFERRED ISAM OUTPUT FLAG
JUMPE AC5,OPNI61 ; 0 = NO DEFERRED OUTPUTS
SKIPN F.WSMU(I16) ; NO DEFERRED OUTS IF SIMU-UPDATE
SETOM BRISK(I12)
;CHECK FILTAB BLKFTR VS STAT-BLK BLKFTR
OPNI61: LDB AC0,F.BMRS ;[371] GET PROGRAMS MAX REC SIZE
CAMN AC0,RECBYT(I12) ;[371] SEE IF SAME AS ISAM PARM
JRST OPNI07 ;[371] IT DOES- OF
CAML AC0,RECBYT(I12) ; [375] WHICH WAY IS FD DIFFERENT?
JRST OPNGR ; [375] FD GT ISAM
TLNN FLG,OPNIN ;[622] [375] FD LT IDX-FILE, OPN OUTPUT ONLY?
JRST OPNI07 ; [375] YES OKAY
JRST OPNER1 ; [375] NO-INPUT OR I/O ERROR
OPNGR: TLNN FLG,OPNOUT ; [622] [375] FD GT IDXFIL - OPN FOR INPUT ?
JRST OPNI07 ; [375] YES OKAY
OPNER1: OUTSTR [ASCIZ /Users maximum record size /] ; [375] [371]
PUSHJ PP,PUTDEC ;[371] TYPE IT
OUTSTR [ASCIZ / differs from ISAM parameter./] ;[371]
MOVE AC0,RECBYT(I12) ;[371] GET ISAM MAX REC SIZE
PUSHJ PP,PUTDEC ;[371] TYPE IT
JRST OPNERX ;[371] FINISH UP MSG AND STOP RUN
OPNI07: MOVE AC6,ORCBYT(I12) ;[515] GET BLOCKFTR AT RESET
CAMGE AC6,RECBYT(I12) ;[535] [515] MUST = OR LESS THAN FILE OPENED
JRST OPNER2 ;[515] NOT THE SAME TROUBLE
MOVE AC6,F.WIKD(I16) ;[535] [515] GET KEY DESC. FROM PROG
CAMN AC6,KEYDES(I12) ;[515] MUST BE THE SAME AS FILE OPENED
JRST OPNI7A ; ELSE CONT NEXT TEST
LDB AC10,KY.TYP ; GET KEY TYPE IN AC10
CAIL AC10,3 ; CHECK FOR VARIOUS FLAVORS OF COMP KEYS;
CAILE AC10,5 ; 3= 1WD COMP, 4=2WD COMP, 5=COMP-1
JRST OPNI7D ; NOT COMP, GIVE WARNING
; COMP, CHECK WITHOUT SIZE FIELD
TRZ AC6,KEYSIZ ; CLEAR SIZE FIELD
MOVE AC10,KEYDES(I12) ; GET ISAM DESCP.
TRZ AC10,KEYSIZ ; CLEAR SIZE HERE TOO
CAIN AC6,(AC10) ; OK NOW?
JRST OPNI7A ; YES, CONT
OPNI7D: OUTSTR [ASCIZ / [Key descriptor of /]
PUSHJ PP,MSFIL. ; PRINT FILE NAME
OUTSTR [ASCIZ / differs from program]
/] ;[535] YOUR ON YOUR OWN AFTER THIS
OPNI7A: MOVE AC6,F.WBRK(I16) ;[574] GET PROGRAM KEY POINTER
HRRZ AC10,F.RREC(I16);GET START OF RECORD
SUBI AC6,(AC10) ;GET IN RELATIVE FORM
CAMN AC6,DBPRK(I12) ;[574] MUST BE SAME AS FILE OPENED
JRST OPNI7B ;OK, CONT
;[617] BYTE PTRS ARE NOT THE SAME, MAY BE BECAUSE OF MODE TRANSLATION
;[617] CALC BYTE OFFSET TO THE BEGINING OF THE KEY AND COMPARE THIS
;[617] CHECK FOR THE SPECIAL CASE OF COMP
LDB AC10,KY.TYP ;[617] GET KEY TYPE IN AC10
CAIL AC10,3 ;CHECK FOR VARIOUS FLAVORS OF COMP KEYS;
CAILE AC10,5 ;3= 1WD COMP, 4=2WD COMP, 5=COMP-1
JRST OPNI7C ;[617] NOT COMP, JUMP TO BYTE POS CHECK
; 4/28/80: EDIT 617 ENHANCED TO ALSO CHECK FOR COMP-1.
; THE COMPILER GENERATES A 9-BIT BYTE PTR FOR COMP THINGS,
; AND ISAM DOES NOT. SOMEDAY THE COMPILER COULD BE FIXED SO
; THIS CODE IS UNNECESSARY.
HRRZ AC10,AC6 ;[617] GET WORD OFFSET OF KEY ONLY
HRRZ AC6,DBPRK(I12) ;[617] GET ISAM-GENERATED WORD OFFSET
CAMN AC10,AC6 ;[617] IF THEY MATCH, SKIP PRINTING
JRST OPNI7B ;[617] OF ERROR MESSAGE
; ELSE ERROR, RESET WORD OFFSET TO BYTE OFFSET FOR MESSAGES
LDB AC3,[POINT 2,FLG,14] ; GET CORE DATA MODE
HRRZ AC3,RBPTBL(AC3) ; AND THEN CHARS PER WORD
IMULI AC10,(AC3) ; RESET PRG OFFSET TO BYTES
IMULI AC6,(AC3) ; RESET ISAM OFFSET TO BYTES
JRST OPNERR ; ERROR
;[617] FIRST CALC BYTE OFFSET FOR THE IDX STAT DESCRIPTION
OPNI7C: LDB AC3,KY.MOD ;[617] GET MODE OF KEY
HRRZ AC3,RBPTB1(AC3) ;[617] GET BYTES PER WORD
LDB AC0,[POINT 6,DBPRK(I12),5] ;[617] GET BIT OFFSET FOR IDX STAT
LDB AC1,[POINT 6,DBPRK(I12),11] ;[617] GET BITS PER BYTE
IDIV AC0,AC1 ;[617] CALC NUMBER BYTES IN FIRST WORD OF KEY
MOVE AC1,AC3 ;[617] GET BYTES PER WORD
SUB AC1,AC0 ;[617] CALC NUMBER OF BYTES BFR KEY IN FIRST WD
HRRZ AC6,DBPRK(I12) ;[617] GET NUM FULL WORDS TO KEY
IMULI AC6,(AC3) ;[617] CALC NUMBER BYTES TO KEY (FULL WDS)
ADD AC6,AC1 ;[617] PLUS PARTIAL = BYTES TO KEY FOR IDX STAT
;[617] CALC NUMBER OF BYTES TO BEGIN OF KEY IN INTERNAL RECORD FORMAT
LDB AC3,[POINT 2,FLG,14] ;[617] GET CORE DATA MODE
HRRZ AC3,RBPTBL(AC3) ;[617] AND THEN CHARS PER WORD
LDB AC0,[POINT 6,F.WBRK(I16),5] ;[617] GET BIT OFFSET FOR IDX STAT
LDB AC1,[POINT 6,F.WBRK(I16),11] ;[617] GET BITS PER BYTE
IDIV AC0,AC1 ;[617] CALC NUMBER BYTES IN FIRST WORD OF KEY
MOVE AC1,AC3 ;[617] GET BYTES PER WORD
SUB AC1,AC0 ;[617] CALC NUMBER OF BYTES BFR KEY IN FIRST WD
HRRZ AC10,F.WBRK(I16) ;[617] GET NUM FULL WORDS TO KEY
HRRZ AC0,F.RREC(I16) ;GET RECORD BASE
SUB AC10,AC0 ;GET NUMBER OF FULL WORDS
IMULI AC10,(AC3) ;[617] CALC NUMBER BYTES TO KEY (FULL WDS)
ADD AC10,AC1 ;[617] PLUS PARTIAL = BYTES TO KEY FOR PROGRAM
CAIE AC6,(AC10) ;[617] IS THE BYTE OFFSET TO THE KEY THE SAME??
JRST OPNERR ;[617] NO, TOO BAD
OPNI7B: PUSHJ PP,OPNWPB ;AC5 = BLKFTR, AC10 = WPB
TLNE FLG,IDXFIL ;ISAM FILE?
SKIPN PAGBUF(I12) ;YES, & PAGE I/O TOO?
JRST OPNI7E ; NO
ADDI AC10,777 ; YES, AT LEAST 512 WD/PG
TRZ AC10,777 ;ROUND UP
OPNI7E: MOVE AC6,DBF(I12) ;DATA FILE BLOCKING FACTOR VIA STA BLOCK
CAMN AC5,AC6 ;AC5 = BLKFTR VIA FILE TABLE
JRST OPNI05 ;OK
MOVX AC0,E.FIDX+FE%9 ;ERROR NUMBER
PUSHJ PP,IGCVR ;IGNORE THE ERROR?
JRST RCHAN ;YES - RELEASE IO CHANS
PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /Users blocking factor /] ; [371]
MOVE AC0,AC5 ;[371] GET USER BF
PUSHJ PP,PUTDEC ;[371] TYPE IT
OUTSTR [ASCIZ / differs from ISAM parameter /] ;[371]
MOVE AC0,AC6 ;[371] GET ISAM BF
PUSHJ PP,PUTDEC ;[371] TYPE IT
OPNERX: SKIPL WANT8. ;WANT 8x FUNCT?
JRST OPNERY ; NO
MOVEI AC0,FS%39 ;SET UP F-S CODE FOR ATTRIB CONFLICT
MOVEM AC0,FS.FS ; AND SAVE IT ASIDE
MOVEI AC0,FE%59 ;ERROR NUMBER
PUSHJ PP,IGCVR ;DO REPORTING
TRN ;IGNORE ERROR IF IT RETURNS
OPNERY: MOVE AC2,[BYTE (5) 10,31,20,2]
PUSHJ PP,MSOUT.
OPNER2: PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /RESET maximum record size /] ;[515]
MOVE AC0,AC6 ;[515] GIVE HIM RESET VALUE
PUSHJ PP,PUTDEC ;[515] TYPE IT
OUTSTR [ASCIZ / differs from OPEN maximum size /] ;[515]
MOVE AC0,RECBYT(I12) ;[515] GET OPEN VALUE
PUSHJ PP,PUTDEC ;[515] TYPE IT
JRST OPNERX ;[515] FINISH UP AND GET OUT
OPNER4: PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /Entries per index block at OPEN /]
PUSHJ PP,PUTDEC ;[515] TYPE OPEN VALUE
OUTSTR [ASCIZ / differs from RESET value /]
MOVE AC0,OEPIB(I12) ;[515] GET RESET VALUE
PUSHJ PP,PUTDEC ;[515] TYPE VALUE
JRST OPNERX ;[515] AND GET OUT
OPNERR: OUTSTR [ASCIZ /?Key pointer of /]
PUSHJ PP,MSFIL. ;[617] PRINT FILE NAME
OUTSTR [ASCIZ / differs from program./] ;[617] [574]
OUTSTR [ASCIZ /
Program key starts at byte /]
MOVE AC0,AC10 ; GET OFFSET TO PROGRAM KEY
PUSHJ PP,PUTDEC ; PRINT IT
OUTSTR [ASCIZ /
ISAM file key starts at byte /]
MOVE AC0,AC6 ; GET ISAM KEY START POSITION
PUSHJ PP,PUTDEC ; PRINT IT
JRST OPNERX ; ERROR MESS AND KILL
;IOWRD(I12) - SET DATA BLOCK IOWD POINTER
OPNI05: MOVN AC5,AC10 ;
HRL AC2,AC5 ;
SKIPN IOWRD(I12) ;SKIP IF ALREADY SETUP BY PREVIOUS OPEN
MOVEM AC2,IOWRD(I12) ;DATA BLOCK
ADDI AC2,1(AC10) ;AC2 POINT AT NEXT FREE AREA
;IBLEN - LEN OF INDEX BLOCK FOR BINARY SEARCH
MOVE AC0,EPIB(I12) ;
CAMLE AC0,OEPIB(I12) ;[535] [515] IS IT THE SAME AS RESET?
JRST OPNER4 ;[515] NO TROUBLE
IMUL AC0,IESIZ(I12) ;NO. OF WRDS IN IDX BLK
MOVEM AC0,IBLEN(I12) ;IDX BLK LEN
;SINC - SEARCH INCREMENT FOR BINARY SEARCH
MOVE AC1,IESIZ(I12) ;THE INCREMENT TO BE
IMULI AC1,2 ;
CAMG AC1,AC0 ;INC GT INDEX LENGTH?
JRST .-2 ;NO
MOVEM AC1,SINC(I12) ;SAVE THE SEARCH INCREMENT
;DAKBP - BYTE POINTER TO DATA ADJUSTED KEY
MOVE AC1,DBPRK(I12) ;START WITH RELATIVE DATA KEY BP
HRRI AC1,(AC2) ;
MOVEM AC1,DAKBP(I12) ;DATA ADJUSTED KEY BYTE POINTER
SETZM (AC1) ;ZERO THE FIRST DATA REC-KEY WRD
ADDI AC1,1 ;
MOVEM AC1,DAKBP1(I12) ;POINTER TO SECOND REC-KEY WRD
ADD AC1,IESIZ(I12) ;KEY SIZE PLUS 2 WRD HDR
SUBI AC1,2 ;PERMIT 1 EXTRA WRD FOR WRAP-AROUND
SETZM -1(AC1) ;ZERO LAST DATA REC-KEY WRD
;RESERVE AREA FOR INDEX ENTRY
ADDI AC1,2 ;LOC FOR BLOCK # AND VERSION #
IFN ISTKS,<
MOVE AC0,[INSSSS(LVL)]
ADD AC0,I12
MOVEM AC0,INSSS0(I12)
MOVE AC0,[OUTSSS(LVL)]
ADD AC0,I12
MOVEM AC0,OUTSS0(I12)
>
;IAKBP - BYTE POINTER TO INDEX ADJUSTED KEY
TLZ AC1,770000 ;
TLO AC1,440000 ;
MOVEM AC1,IAKBP(I12) ;INDEX ADJUSTED KEY BP
ADDI AC1,1 ;
MOVEM AC1,IAKBP1(I12) ;POINTER TO SECOND IDX-KEY WRD
ADD AC1,IESIZ(I12) ;
SUBI AC1,2 ;
SETZM -1(AC1) ;ZERO LAST IDX-KEY WRD
; RESERVE ANOTHER COPY OF THE KEY FOR REWRT/DEL
; SAVE OF CNTRY KEY VALUE, THE INDEXED ADJ VERSION OF THE KEY
; (LEFT JUSTIFIED) WILL BE KEPT
MOVEM AC1,RWDLKY(I12) ; SAVE ADDR OF KEY SAV AREA
MOVE AC2,IESIZ(I12) ; RESERVE ROOM FOR
SUBI AC2,1 ; COPIES OF IAK AND DAK KEYS
LSH AC2,1 ; MULTIPLE BY 2
ADDI AC1,2(AC2) ; AND ADD IN EXTRA 2 WORDS ALLOWED FOR
; IN OPNI05 FRO INDEX HDR WDS
MOVEM AC1,RWDLRT(I12) ; And a save area for RETAIN too
ADDI AC1,2(AC2) ;
;AC1 POINTS TO NEXT FREE AREA
HRLI AC1,-1(AC1) ;UNTIL
HRRI AC1,ICHAN(I12) ;UNTIL,,FROM
SKIPN CORE0(I12) ; SKIP IF NOT THE FIRST OPEN
MOVEM AC1,CORE0(I12) ;CLOSE CLEARS THIS CORE AREA
;AUXIOW - SETUP THE IOWD
MOVN AC0,MXBUF ;MAX BUFFER SIZE
HRL AC0,AC0 ;
HRR AC0,AUXBUF ;
SUBI AC0,1 ;LOC-1
MOVEM AC0,AUXIOW ;SAVE IT
;KWCNT - NUMBER OF WORDS IN THE KEY
MOVE AC1,IESIZ(I12) ;SETUP KWCNT
SUBI AC1,2 ;
;HRRM AC1,IKWCNT(I12) ;
;HRRM AC1,DKWCNT(I12) ;
MOVNS AC1 ;
HRLM AC1,IKWCNT(I12) ;-CNT,,CNT
;FWMASK, LWMASK - CREATE 2 MASK WORDS FOR FIRST AND LAST DATA-KEY WORDS
LDB AC0,KY.TYP ; GET KEY TYPE
JUMPN AC0,OPNBPS ; JUMP IF NOT NON-NUMERIC DISPLAY
LDB AC1,KY.SIZ ; GET KEY SIZE
MOVN AC2,AC1 ;
HRLZS AC2 ;
MOVE AC3,DBPRK(I12) ;RELATIVE DATA-RECORD-KEY POINTER
OPNMSK: IBP AC3
AOBJN AC2,.+1
TLNE AC3,760000 ;STAY WITH IN THE FIRST WORD
JUMPL AC2,OPNMSK ;UNLESS WE RUN OUT OF BYTES
LDB AC4,[POINT 6,DBPRK(I12),5]
SETZ AC5, ;
SETO AC6, ;
LSHC AC5,(AC4) ;
MOVEM AC5,FWMASK(I12) ;007777 FIRST WORD MASK
TLNN AC3,760000 ;
JRST OPNMS1 ;
LDB AC4,[POINT 6,AC3,5] ;THE KEY IS LESS THAN ONE WORD
MOVNS AC4 ;
LSH AC5,(AC4) ;
MOVNS AC4 ;
LSH AC5,(AC4) ;
JRST .+2 ;007700 AC5 HAS MASK
OPNMS1: JUMPL AC2,OPNMS2 ;IS KEY GREATER THAN ONE WRD?
SETZM FWMASK(I12) ;NO, ONE WRD OR LESS
MOVEM AC5,LWMASK(I12) ;
JRST OPNBPS ;DONE
OPNMS2: LDB AC4,KY.MOD ; GET MODE OF KEY
HRRZ AC4,RBPTB1(AC4) ; GET BYTES PER WORD
HLRES AC2 ;
MOVMS AC2 ;MAKE IT POSITIVE
IDIV AC2,AC4 ;
SKIPN AC3 ;REMAINDER?
SKIPA AC3,AC4 ;NO--BYTES PER WORD
ADDI AC2,1 ;YES
LDB AC4,[POINT 6,DBPRK(I12),11]; GET BITS PER BYTE
MOVNS AC2 ;
HRLM AC2,DKWCNT(I12) ;NUMBER OF REC-WRDS -1 THAT CONTAIN THE KEY
IMUL AC3,AC4 ;
SETO AC6, ;
SETZ AC5, ;
MOVNS AC3
ROTC AC5,(AC3) ;
MOVEM AC5,LWMASK(I12) ;MASK FOR THE LAST REC-DATA-KEY WRD
;BPSB - NUMBER OF BITS PER SAT BLOCK
OPNBPS: MOVE AC0,FILSIZ(I12) ;TOTAL NUMBER OF DATA BLOCKS IN FILE
IDIV AC0,SBTOT(I12) ; WILL GIVE NUMBER PER SAT BLOCK
MOVEM AC0,BPSB(I12) ;SAVIT
;ICMP, DCMP - SETUP DISPATCH ADR FOR COMPARE ROUTINES
;0 = DCDNN, 1 = DC1S/U, 2 = DC2S/U
OPNDSP: LDB AC2,KY.TYP ; GET KEY TYPE
JUMPE AC2,OPNDS1 ; ZERO STAYS A ZERO
TRNE AC2,1 ;
TRZA AC2,-2 ; ODD BECOMES 1
HRRZI AC2,2 ; EVEN BECOMES 2
OPNDS1: TLNE FLG,DDMASC ;[1207] IF FILE IS ASCII, TREAT IT
HRRZI AC2,0 ;[1207] AS NON-NUMERIC
HRRZ AC0,KEYDES(I12) ; GET KEY SIGN
TRNE AC0,100000 ;
SKIPA AC3,ICTAB(AC2) ;UNSIGNED
MOVS AC3,ICTAB(AC2) ;SIGNED
HRRZM AC3,ICMP(I12) ;INDEX COMPARE ROUTINE
TRNE AC0,100000 ;
SKIPA AC3,DCTAB(AC2) ;
MOVS AC3,DCTAB(AC2) ;
HRRZM AC3,DCMP(I12) ;DATA COMPARE ROUTINE
LDB AC5,KY.TYP ; GET KEY TYPE
CAIGE AC5,3 ; 0 THRU 8
JUMPN AC5,OPNDS2 ; 0, 1, 2
CAIGE AC5,7 ; 0, 3, 4, 5, 6, 7, 8
JRST OPNRSB ; 0, 3, 4, 5, 6
;HERE IF NUMERIC DISPLAY OR COMP-3
;SETUP CONVERT TO BINARY ROUTINES
OPNDS2: HLLZ AC1,F.WBRK(I16) ;POSITION IN DATA-REC
TRNE AC0,100000 ;
TLZA AC1,4000 ;UNSIGNED
TLO AC1,4000 ;SIGNED ???
LDB AC2,KY.SIZ ; GET KEY SIZE
DPB AC2,[POINT 11,AC1,17] ;
MOVEM AC1,GDPRK(I12) ;GD PARAMETER FOR REC-KEY
HRR AC1,F.WBSK(I16) ;ADR OF RECORD KEY
TLZ AC1,770000 ;MASK
HLLZ AC2,F.WBSK(I16) ;
TLZ AC2,7777 ;
IOR AC1,AC2 ;RECORD KEY BYTE RESIDUE
MOVEM AC1,GDPSK(I12) ;GD PARAMETER FOR RECORD KEY
LDB AC2,[POINT 2,FLG,14] ; GET KEY MODE
HRRZ AC1,GDTBL(AC2) ; GET CONVERSION ROUTINE
CAIL AC5,7 ; IF COMP-3
HRRZI AC1,GC3. ; USE THIS ROUTINE
MOVEM AC1,GDX.I(I12) ; RECORD KEY VS INDEX ENTRY
LDB AC2,KY.MOD ; GET KEY MODE
HLRZ AC1,GDTBL(AC2) ; GET CONVERSION ROUTINE
CAIL AC5,7 ; IF COMP-3
HRRZI AC1,GC3. ; USE THIS ROUTINE
MOVEM AC1,GDX.D(I12) ; RECORD KEY VS DATA FILE KEY
;DCMP,DCMP1 - SETUP TO CONVERT THEN COMPARE
HRRZM AC3,DCMP1(I12) ;COMPARE ROUTINE
HRRZI AC3,DGD67 ;CONVERSION ROUTINE
MOVEM AC3,DCMP(I12) ;CONVERT THEN COMPARE
;RSBP - BR TO SIXBIT/ASCII RECORD SIZE
OPNRSB: MOVE AC1,[POINT 12,-1(AC4),35]
TLNN FLG,DDMSIX!DDMEBC;
MOVE AC1,[POINT 12,-1(AC4),34]
MOVEM AC1,RSBP(I12)
SUBI AC1,-1
MOVEM AC1,RSBP1(I12)
;GETSET - SETUP KEY FOR SEARCH ROUTINES
OPNGST: LDB AC1,KY.TYP ; GET KEY TYPE
JUMPN AC1,.+2 ;
MOVEI AC2,ADJKEY ;DNN
CAIE AC1,1 ;
CAIN AC1,2 ;
MOVEI AC2,GD67 ;DN
CAIL AC1,3 ;
MOVEI AC2,FPORFP ;FP
CAIE AC1,7 ; COMP-3?
CAIN AC1,10 ; ?
MOVEI AC2,GD67 ; YES
MOVEM AC2,GETSET(I12) ;DISPATCH FOR SEARCH INITIALIZING
;RECBP - SETUP REC AREA BYTE-POINTER
LDB AC2,[POINT 2,FLG,14]; GET MODE OF RECORD AREA
HLL AC2,RBPTB1(AC2) ; GET A BYTE-PTR
HRR AC2,FLG ;ADR OF REC
MOVEM AC2,RECBP(I12) ;
;NOW CLEAR SOME IDX BUFFER AREAS
MOVEI AC6,IOWRD+2(I12); START WITH SECOND IDX LEVEL
OPNZBF: SKIPN AC2,(AC6) ; GET THE IOWRD TO AC2
JRST OPNZB1 ; THERE IS NONE FOR THIS LEVEL
HRLI AC1,1(AC2) ; THE "FROM" ADDR
HRRI AC1,2(AC2) ; THE "TO" ADDR
SETZM -1(AC1) ; ZERO FIRST WORD
HLRO AC2,AC2 ; GET THE LENGTH
HRRZI AC3,-2(AC1) ; GET "FROM"-1
SUB AC3,AC2 ; GET "UNTIL" ADDR
BLT AC1,(AC3) ; SMEAR THE ZERO
OPNZB1: CAIE AC6,IOWRD+13(I12);SKIP WHEN DONE
AOJA AC6,OPNZBF ; ELSE LOOP
JRST OPNCH2 ;
OPNIR0: MOVEI AC0,FS%30 ;PERMANENT ERROR
MOVEM AC0,FS.FS ;LOAD FILE-STATUS
MOVX AC0,E.FIDX+FE%7 ;ERROR NUMBER
PUSHJ PP,IGCVR ;IGNORE ERROR?
JRST RCHAN ;YES - RELEASE IO CHANNELS
OUTSTR [ASCIZ /Cannot expand core while SORT is in progress./]
JRST OMTA99
OPNIR1: MOVEI AC0,FS%30 ;PERMANENT ERROR
MOVEM AC0,FS.FS ;LOAD FILE-STATUS
MOVX AC0,E.FIDX+FE%8 ;ERROR NUMBER
PUSHJ PP,IGCVR ;IGNORE ERROR?
JRST RCHAN ;YES - RELEASE IO CHANS
PUSHJ PP,GETSP9 ;CORE UUO FAILED
JRST OMTA99
;DISPATCH FOR INDEX COMPARE ROUTINES
ICTAB: XWD ICDNN, ICDNN ;DISPLAY NON-NUMERIC
XWD IC1S, IC1U ;ONE WRD SIGNED / UNSIGNED
XWD IC2S, IC2U ;TWO WRD SIGNED / UNSIGNED
;DISPATCH FOR DATA COMPARE ROUTINES
DCTAB: XWD DCDNN, DCDNN ;DISPLAY NON-NUMERIC
XWD DC1S, DC1U ;ONE WRD SIGNED / UNSIGNED
XWD DC2S, DC2U ;TWO WRD SIGNED / UNSIGNED
;DISPATCH FOR DATA CONVERSION ROUTINES
PDTBL: PD6.,,GD6. ; SIXBIT TO BINARY
PD9.,,GD9. ; EBCDIC
PD7.,,GD7. ; ASCII
;INDEX TO LEFT HALF IS KY.MOD FOR DSRCH
;INDEX TO RIGHT-HF IS CORE-DATA-MODE FOR IBS
GDTBL: GD6.,,GD7.
GD9.,,GD9.
GD7.,,GD6.
;RETURNS IN AC10 NUMBER OF WORDS PER LOGICAL BLOCK
;AND BLOCKING FACTOR IN AC5. ***POPJ***
OPNWPB: LDB AC5,F.BBKF ;BLOCKING FACTOR
MOVEM AC5,D.RCL(I16) ;
LDB AC10,F.BMRS ;MAX RECORD SIZE
TLNE FLG,IDXFIL ; [375] IS THIS AN ISAM FILE?
MOVE AC10,RECBYT(I12); [375] YES-USE ISAM PARAM
TLNE FLG,DDMBIN ;IF MODE IS BINARY,
JRST OPNWP3 ; CONVERT SIZE TO WORDS
JUMPL FLG,OPNWP1 ;JUMP IF ASCII
OPWPB0: LDB AC6,[POINT 2,FLG,2] ; GET DEVICE DATA MODE
HRRZ AC6,RBPTBL(AC6) ; AND THEN CHARS PER WORD
OPWPB1: HRRZM AC6,D.BPW(I16) ; CHARS PER WORD
TLNE FLG,DDMEBC ; SKIP IF NOT EDCBIC
JRST OPNWP4 ; EBCDIC!
OPNWP5: ADD AC10,AC6 ; ACCOUNT FOR THE HEADER WORD
OPNWP2: ADDI AC10,-1(AC6) ;ROUND UP
IDIV AC10,AC6 ;RECSIZ/CPW
HRRZM AC10,D.WPR(I16) ; SAVE WRDS-PER-RECORD
IMUL AC10,AC5 ;WORDS PER LOGBLK
JUMPE AC5,.+2 ; SKIP IF 0 BLK-FACTOR
TXNN AC13,DV.MTA ; SKIP IF MTA
POPJ PP, ; ELSE CONTINUE
CAIGE AC10,MINMTA ; SKIP IF LOG BLK NOT TOO SMALL
MOVEI AC10,MINMTA ; ELSE USE MINIMUM MTA SIZE
IMUL AC6,AC10 ; CALC CHARS/LOG-BLK
MOVEM AC6,D.TCPL(I16) ; SAVE CHARS PER LOG-BLK
POPJ PP, ;
OPNWP4: SKIPGE D.F1(I16) ; IF VARIABLE LEN EBCDIC RECORDS
ADDI AC10,(AC6) ; INCLUDE RDW WITH REC-SIZE
JRST OPNWP6 ;
OPNWP1: HRRZ AC6,D.RFLG(I16) ; GET RUNTIME FLAGS
TRNN AC6,SASCII ; STANDARD ASCII?
ADDI AC10,2 ; NO, ACCOUNT FOR CRLF
TRNE AC6,INDASC ; IS IT INDUSTRY-COMP ASCII?
TXNN AC13,DV.MTA ; YES,IS DEVICE A MTA?
JRST OPWP6B ; NO,CONT
; HERE FOR ASCII WITH INDUSTRY COMPAT. MODE
MOVEI AC6,4 ; FOUR CHARS PER WORD FOR IND-ASCII TAP
TDNA ; SKIP
OPWP6B: MOVEI AC6,5 ; FIVE CHARS PER ASCII WORD
HRRZM AC6,D.BPW(I16) ; CHARS PER WORD
OPNWP6: TLNE FLG,IDXFIL ;[372] INDEX FILE?
JRST OPNWP5 ;[372] YES USE DIFFERENT CALC
TLNE FLG,RANFIL ; SKIP IF NOT DUMP MODE RANDOM IO
TLNN FLG,DDMASC!DDMEBC ; SKIP IF ASCII OR EBCDIC FILE
JRST OPWP6A ; ELSE GO ON
; EBCDIC AND ASCII RAN/IO RECS ARE WORD BLOCKED
ADDI AC10,-1(AC6) ; ROUND UP
IDIVI AC10,(AC6) ; GET WRDS PER REC
HRRZM AC10,D.WPR(I16) ; SAVE WRDS-PER-RECORD
IMUL AC10,AC5 ; GET WRDS PER BLOCK
MOVEM AC10,AC6 ; SETUP AC6
JRST OPNWP8 ; NOW GO ON
OPWP6A: MOVEM AC10,D.CPR(I16) ; SAVE CHARS PER RECORD FOR NON RANDOM FILES
IMUL AC10,AC5 ;[372] NO. OF CHARS IN LOGIGAL BLOCK
PUSH PP,AC10 ; SAVE CPL
ADDI AC10,-1(AC6) ;[372] ROUND UP
IDIVI AC10,(AC6) ;[372] NO. OF WORDS PER LOGICAL BLOCK
POP PP,AC6 ; RESTORE CHARS-PER-LOGI-BLK
OPNWP8: MOVEM AC6,D.TCPL(I16) ; TOTAL CHARS/LOG-BLOCK
TLNE FLG,OPNIN ; D.FCPL MUST BE ZERO FOR
SETZ AC6, ; THE FIRST READ UUO
MOVEM AC6,D.FCPL(I16) ; FREE CHARS/LOG-BLOCK
TXNE FLG1,B%VLER ;[431] VAR-LEN EBCDIC FILE?
ADDI AC10,1 ; YES - ADD 1 FOR BDW
JUMPE AC5,.+2 ; SKIP IF 0 BLK-FACTOR
TXNN AC13,DV.MTA ; SKIP IF MTA
POPJ PP, ; ELSE CONTINUE
CAIGE AC10,MINMTA ; SKIP IF LOG BLK NOT TOO SMALL
MOVEI AC10,MINMTA ; ELSE USE MINIMUM MTA SIZE
POPJ PP, ; [372]
;RECORDING MODE IS BINARY--CONVERT SIZE TO WORDS
OPNWP3: MOVEI AC6,1 ; BINARY FILES
MOVEM AC6,D.BPW(I16) ; HAVE ONE BYTE PER WORD
LDB AC6,[POINT 2,FLG,14] ; GET CORE DATA MODE
HRRZ AC6,RBPTBL(AC6) ; AND THEN CHARS PER WORD
JRST OPNWP2
;SET DEVICE TABLE BUFFER HEADER BYTE SIZE
;SETUP CONVERSION FLG ***OPNLO***
OPNBSI:
HRRZ AC1,D.RFLG(I16) ; GET RUNTIME FLAGS
TRNE AC1,INDASC ; IS IT INDUSTRY-COMP ASCII?
JRST OPNBS0 ; YES, SO SET 8 BIT BYTES AND INDUSTRY COMPAT-MODE
JUMPGE FLG,OPNBS3 ;JUMP IF DEVICE IS NOT ASCII
MOVEI AC6,7 ; ASCII GETS 7 BITS
JRST OPNBS1 ; GO SET IT, NEEDED FOR BYTE MODE CASES
OPNBS3: TLNE FLG,DDMBIN ;IF MODE IS BINARY,
JRST OPNBPB ; DON'T TOUCH BYTE POINTER
MOVEI AC6,6 ;SIXBIT BYTE SIZE
TLNN FLG,DDMEBC ; SKIP IF EBCDIC
JRST OPNBS1 ; NOT EBCDIC
MOVEI AC6,^D9 ; EBCDIC IS 9 BITS WIDE
TXNN AC13,DV.MTA ; IS DEVICE A MTA?
JRST OPNBS1 ; NO
HRRZ AC1,F.WDNM(I16) ; HOW MANY TRACKS ON THIS DRIVE?
MOVE AC1,(AC1) ; SIXBIT DEVICE NAME FOR
MTCHR. AC1, ; GET CHARACTERISTICS
SETZ AC1, ;[431] ERROR RET - ASSUME ITS OK (IE 9TRK)
TRNE AC1,MT.7TR ; 9 CHANNEL?
JRST OPNBS1 ; 7 CHANNEL.
OPNBS0: MOVEI AC6,^D8 ; 9TRK SO 8 BITS WIDE
OPNBS2: XCT MTIND. ; AND INDUSTRY COMPATIBLE MODE
OPNBS1: DPB AC6,DTIBS. ;INPUT HEADER BYTE-POINTER
DPB AC6,DTOBS. ;OUTPUT H...
OPNCON: LDB AC0,[POINT 3,FLG,2] ; GET DEVICE DATA MODE
LDB AC1,[POINT 3,FLG,14] ; GET CORE DATA MODE
CAME AC0,AC1 ; EQUAL?
TLO FLG,CONNEC ; NO, SET THE CONVERSION FLAG
;PRESUMES AC10 HAS WRDS/LOGICAL BLOCK
;SETUP BUFFERS PER LOGICAL BLOCK AND
;NUMBER OF RECORDS TO A RERUN DUMP
;AND THE CONVERSION INSTRUCTION.
OPNBPB: LDB AC1,[POINT 2,FLG,2] ; GET DEVICE DATA MODE
LDB AC2,[POINT 2,FLG,14] ; AND CORE DATA MODE
MOVE AC3,@RCTBL(AC1) ; GET CONVERSION INSTRUCTION
TLNE FLG,DDMBIN ; IF A BINARY DEVICE
MOVSI AC3,(TRN) ; NO CONVERSION
MOVEM AC3,D.RCNV(I16) ; SAVE FOR LATER - READ
MOVE AC3,@WCTBL(AC2) ; GET CONVERSION INSTRUCTION
TLNE FLG,DDMBIN ; IF A BINARY DEVICE
MOVSI AC3,(TRN) ; NO CONVERSION
MOVEM AC3,D.WCNV(I16) ; SAVE FOR LATER - WRITE
HRRZ AC10,F.RRRC(I16);GET RERUN RECORD COUNT
HRRZM AC10,D.RRD(I16) ;NUMBER OF RECORDS TO A RERUN DUMP
LDB AC10,F.BCRC ; GET CHK-PNT REC COUNT
JUMPE AC10,.+2 ; SKIP IF NONE SET (D.CRC MAY NOT BE THERE)
MOVEM AC10,D.CRC(I16) ; ELSE,INITIALIZE IT
TXNE AC16,OPN%EX ; SKIP IF NOT OPEN EXTEND
JRST OPNBP4 ; ELSE,CONT D.BCL ALREADY SET
MOVE AC10,D.BPL(I16) ; GET BUFFS PER LOG-BLK
TXNE FLG1,B%VLER ; IF EBCDIC VARIABLE LEN-RECS INIT
SETZ AC10, ; D.BCL TO ZERO FOR FIRST READ UUO
MOVEM AC10,D.BCL(I16) ;CURRENT BUFBLK
OPNBP4: TXNE AC13,DV.MTA ;SKIP IF NOT A MAGTAPE
JRST OPNMTA ;SET DENSITY, PARITY & POSITION THE MAGTAPE
;DO A LOOKUP OR READ A LABEL. SETUP DEVICE TABLE REEL
;NUMBER AND NUMBER OF FIRST BLOCK OF FILE. ***OPNBBF***
OPNLO: TXNN AC16,V%OPEN ;OPEN UUO SKIPS
JRST OPNLO1 ;
MOVEI AC0,' 01' ;SIXBIT REEL NUMBER '01'
TXNN AC16,CLS%RO ;SKIP IF A CLOSE REEL GENERATED OPEN
DPB AC0,DTRN. ;INITIALIZE THE REEL NUMBER
OPNLO1: TLNN FLG,OPNIN!RANFIL!IDXFIL ;SKIP IF INPUT/IO
JRST OPNBBF ;OUTPUT. BBF USE PRO.
OPNLUP: PUSHJ PP,OPNLID ;SETUP LOOKUP BLOCK WITH ID
TXNN AC13,DV.DIR ;SKIP IF DIRECTORY DEVICE
JRST OPNRLB ;READ LABEL INTO RECORD AREA
IFN TOPS20,<
; TLNN FLG,OPNOUT ;[667] IF INPUT (READ) ONLY FOR A DISK FILE
; TXNN AC13,DV.DSK ;[667] WE HAVE ALREADY DONE THE LOOKUP VIA COMPT. UUO
; TRNA ;[1007] NOT
; TXNN AC13,DV.MTA ;[667] WE HAVE ALREADY DONE THE LOOKUP VIA COMPT. UUO
JRST [TLNE FLG,RANFIL ;[1050] IF RANDOM FILE,
PUSHJ PP,OPNEL2 ;[1050] SET D.LBN, LAST BLK NBR
JRST OPNLU3] ;[1050] (USE EXTENDED LKUP BLK)
>
SKIPE F.WSMU(I16) ;OR SIMULTANEOUS UPDATE?
JRST OPNLU2 ;[565] YES, DON'T DO LOOKUP
TLNN FLG,OPNIN!IDXFIL; SKIP IF ISAM OR INPUT FILE
PUSHJ PP,OPNENT ; SUPERSEDE THE EXISTING FILE
XCT ULKUP. ;*** LOOKUP ***************
JRST OPNLER ;ERROR RETURN FOR LOOKUP AND COMP.
OPNLU1: TLNE FLG,IOFIL!RANFIL ;[622][475] IF DUMP MODE I-O
PUSHJ PP,OPNEL1 ;[565] CALC D.LBN
JRST OPNLU3 ;[565] AND-OR CONT
OPNLU2: LDB AC0,F.QOPN ;[565] GET SMU OPEN FLAG
JUMPN AC0,OPNLU3 ;[565] JUMP IF OPEN AFTER LFENQ. OPEN
PUSHJ PP,OPNEL2 ;[565] NO SMU OR SMU WITH LFENQ. OPEN,
;[565] SET D.LBN
DMOVE AC0,ARGBK.+.RBEXT ;[612] GET EXTENSION, DATE AND PROTECTION BITS
DMOVEM AC0,ULBLK.+1 ;[612] INTO SHORT LOOKUP BLOCK.
OPNLU3: ;[565]
SETZM D.CBN(I16) ;THE FIRST BLOCK OF ALL
TLNN FLG,RANFIL ; BUT RANDOM FILES
AOS D.CBN(I16) ; IS ONE.
PUSHJ PP,ZROSLA ;ZERO THE STD LABEL AREA
DMOVE AC0,ULBLK. ;FILE NAME & EXTENSION
IFE TOPS20,<
TXNE AC13,DV.DTA ;SKIP IF NOT A DTA
HRRM AC1,D.CBN(I16) ;SAVE AS THE FIRST BLOCK NUMBER
>
TXNN AC13,DV.MTA ;UNLESS MTA
JRST OPNBBF ;DON'T CREATE A LABEL
TRZ AC1,-1 ;THEN ZERO IT
ROTC AC0,14 ;
MOVEM AC0,STDLB.+1 ;
HLLM AC1,STDLB.+2 ;
HRLI AC1,'HDR' ;LABEL TYPE
IORI AC1,'1 '
MOVEM AC1,STDLB. ;
LDB AC4,[POINT 12,ULBLK.+2,35] ;GET LOW ORDER CREA DATE
LDB AC1,[POINT 3,ULBLK.+1,20] ;[274] GET HIGH ORDER
DPB AC1,[POINT 3,AC4,23] ;[274] MERGE THE ORDERS
PUSHJ PP,DATE1. ;CREATION DATE
PUSHJ PP,OPNCA1 ;MOVE STD-LABEL AREA TO RECORD AREA
JRST OPNBBF
;THIS ROUTINE FINDS THE NUMBER OF THE FIRST SECTOR OF THE LAST
;LOGICAL BLOCK OF THE SEQIO FILE
OPNEL1: HLRE AC5,ULBLK.+LKPSIZ ;[565] GET FILE SIZE RETURNED
JUMPGE AC5,OPNEL4 ;[565] SKIP AHEAD IF LOOKUP RETURNS BLKS
MOVNS AC5 ;[565] NEGATE LOOKUP NUMBER OF WRDS
TRNA
OPNEL2: MOVE AC5,ARGBK.+.RBSIZ ; GET LAST BLOCK OF FILE
ADDI AC5,177 ; DIVIDE WORDS WRITTEN BY
IDIVI AC5,200 ; WRDS/BLK AND ROUND UP
OPNEL4: MOVE AC6,D.BPL(I16) ;[565] GET NUMBER OF FIRST
IDIV AC5,AC6 ; LOGICAL BLOCK
IMUL AC5,D.BPL(I16) ;[475] SIZE IN PHYSICAL BLOCKS
SKIPE AC6 ;[475] IF REMAINDER WE HAVE
AOJA AC5,OPNL2A ;[475] PART LAST BLOCK
MOVE AC6,D.BPL(I16) ;[475] LAST BLOCK FULL
SUBI AC6,1 ;[475] CALC FIRST PHYSICAL BLOCK
SUB AC5,AC6 ;[475] OF LAST LOGICAL BLOCK
SKIPG AC5 ;[475] IF FILE DOESN'T EXIST
MOVEI AC5,1 ; ONE IS THE FIRST BLOCK
OPNL2A: MOVEM AC5,D.LBN(I16) ; SAVE IT FOR SEQIO
POPJ PP, ;
OPNLER: MOVEI AC2,FS%30 ;PREPARE TO SET FILE STATUS TO "PERMANENT ERROR"
MOVEM AC2,FS.FS ; FOR ALL TYPES OF LOOKUP ERRORS
HRRZ AC2,ULBLK.+1 ;
TRNE AC2,37 ;IS IT FILE-NOT-FOUND?
JRST OLERR ;NO, OTHER
TLNN FLG,IDXFIL ;DONT MAKE FILE IF ISAM FILE
TLNE FLG,OPNOUT ; OR IF AN INPUT FILE
TLNN FLG,RANFIL!IOFIL ;[622] RANDOM OR IO OUTPUT FILE?
JRST OLERR ;NO
;28-MAY-80: IF THE FILE IS BEING OPENED FOR I/O,
; IT DOESN'T MAKE SENSE TO CREATE A NEW FILE IN COBOL-74,
; BECAUSE HE IS NOT ALLOWED TO USE THE "WRITE" VERB
TLNE FLG,OPNIN ;WE KNOW OUTPUT FLAG IS ON, IS INPUT FLAG
; ON ALSO?
JRST OLERR ;YES, GO GIVE ERROR
;THIS IS A RANDOM OR SEQ. FILE, BEING OPENED FOR I/O OR OUTPUT.
;THE FILE WAS NOT THERE.
SETZM FS.FS ; NOT AN ERROR, CLEAR FILE STATUS
PUSHJ PP,OPNENT ; SO MAKE A NULL FILE
JRST OPNLUP ; OK TRY THE LOOKUP AGAIN
;HERE TO CREATE A NULL FILE FOR USER
OPNENT: PUSHJ PP,OPNEID ;SETUP FOR AN ENTER
XCT UENTR. ;CREATE A NULL FILE
JRST OEERR ;ERROR RETURN
XCT UCLOS.
POPJ PP,
; THIS ROUTINE OPENS A FILE VIA THE "FILOP." UUO
OPNFOP: MOVE AC0,UOBLK. ;SET THE DATA MODE
MOVEM AC0,FOP.IS
TLNN FLG,IDXFIL ; ISAM FILE?
JRST OPNFPD ; NO
TLO FLG1,FOPIDX ; ENTRY FOR ".IDX" FILE
PUSHJ PP,OPNLIX ; GET VID TO LOOKUP BLOCK
MOVE AC0,ICHAN(I12) ; CHANNEL FOR .IDX FILE
JRST OPNFP2
OPNFPD: PUSHJ PP,OPNLID ; GET VID TO LOOKUP BLOCK
LDB AC0,DTCN. ;[576] GET CHANNEL NUMBER
OPNFP2: HRRZ AC5,F.RPPN(I16) ;[576] GET POINTER TO PPN
IFN TOPS20,< ;[644]
SKIPE AC5 ;[576] USE DEFAULT PPN IF NONE
>
IFE TOPS20,<
JUMPN AC5,OPNFP3 ;[644] JUMP IF A PPN GIVEN
;[644] HERE IF NO PPN, SETUP DEFAULT PATH
MOVEI AC1,.PTFRD ;[644] SET READ DEFAULT PATH FUNCTION
MOVEM AC1,PTH.BK## ;[644] INTO ARG BLOCK
MOVE AC1,[XWD .PTMAX,PTH.BK] ;[644] INDICATE PATH ARG BLOCK LOC
PATH. AC1, ;[644] GET DEFAULT PATH
POPJ PP, ;[644] ERROR RETURN
MOVEI AC5,PTH.BK ;[644] INDICATE PATH BLOCK FOR PPN FIELD
MOVE AC1,UOBLK.+1 ;[1030] GET SIXBIT NAME
DEVNAM AC1, ;[1030] IS DEVICE AN ERSATZ?
JRST OPNF2A ;[1030] NO CONTINUE
CAME AC1,UOBLK.+1 ;[1030] SAME NAME?
JRST OPNF2A ;[1030] NO, CONTINUE
DEVPPN AC1, ;[1030] GET PPN
JRST OPNF2A ;[1030] CONTINUE
CAME AC1,PTH.BK+2 ;[1030] SAME PPN?
SETZM PTH.BK+3 ;[1030] MUST BE ERSATZ SO CLEAR SFD
OPNF2A: TDNA ;[1030] [644] SKIP
OPNFP3: > ;[644] END IFE TOPS20
MOVE AC5,(AC5) ;[576] GET THE PPN
MOVEM AC5,ARGBK.##+.RBPPN ;[576] SET PPN OR PATH LOC
MOVE AC5,[ULBLK.,,ARGBK.+.RBNAM];[576] GET FILE NAME
BLT AC5,ARGBK.+.RBEXT ;[576] AND EXTENSION
HLLZS ARGBK.+.RBEXT ;[576] ZERO DATE FIELD
SETZM ARGBK.+.RBPRV ;[576] AND PRIVILIGE FIELD
SETZM ARGBK.+.RBSIZ ;[576] AND SIZE FIELD
HRLI AC0,.FORED ;[576] DO EXTENDED LOOKUP TO SEE IF THERE
TXNE AC16,OPN%EX ; OR OPEN EXTENDED
HRLI AC0,.FOAPP ; APPEND
IORI AC0,(FO.PRV) ;[656] SET BIT 0 ON IN WORD 0 OF FILOP ARG BLK
MOVSM AC0,FOP.BK ; SAVE IN FILOP BLOCK
MOVE AC0,UOBLK.+1 ; GET DEVICE NAME
MOVEM AC0,FOP.DN ;
MOVEI AC0,ARGBK. ;[576] GET ADR OF LOOKUP BLOCK
MOVEM AC0,FOP.LB ;
TXNE AC16,OPN%EX ; IF APPEND
JRST RET.2 ; DELAY UNTIL BUFFERS SET UP
SETZM FOP.BH ;[662] CLEAR BUFFER HDR ADDR WHEN USING DUMP MODE
SETZM FOP.BN ;[662] ..
MOVE AC1,[7,,FOP.BK] ; SET UP FILOP'S AC
FILOP. AC1, ;[576] DO THE LOOKUP
JRST [SKIPN AC1 ;[576]SKIP IF ERROR CODE NON-0
TLNE FLG,IDXFIL ;[576]FILE NOT FOUND,SKIP IF NOT ISAM
POPJ PP, ;[576] GIVE ERROR RETURN
TLC FLG,OPNIN!OPNOUT
TLCE FLG,OPNIN!OPNOUT ;IF OPEN I/O
TXNN AC16,OPN%EX ;OR OPEN EXTEND
SKIPL WANT8. ;[1167] ITS OK, CREATE NON-EXISTENT FILE IF ANS-82 DEFAULT
POPJ PP, ; OTHERWISE GIVE FNF ERROR
MOVE AC1,[7,,FOP.BK] ;[576]RESTORE FILOP ARG
JRST .+1] ;[576]NON ISAM FILE NOT FOUND,WILL CREATE ONE
TLZ FLG1,FOPIDX ;[576] CLEAR FLAG
; HRRZ AC5,F.RPPN(I16) ; [644] GET POINTER TO PPN
; SKIPE AC5 ; [644] USE DEFAULT PPN IF NONE
; MOVE AC5,(AC5) ; [644] GET THE PPN
; MOVEM AC5,ARGBK.+.RBPPN ; [644] RESET PPN IN LKP/ENTR BLK
MOVEI AC0,.FOMAU ;[576] NOW SET FOR
HRRM AC0,FOP.BK ;[576] SIMULTANEOUS UPDATE
FILOP. AC1, ;[576] DO IT *************
POPJ PP, ;[576] ERROR RETURN
JRST RET.2 ;[576] ALL OK,EXIT
; FILOP ERROR
; AC1 CONTAINS THE ERROR CODE RETURNED BY THE FILOP
OFERR: SETZM FS.IF ; IDA-FILE FLAG
OFERRI: MOVEI AC0,FS%30 ;GET FILE-STATUS CODE = PERM. ERROR
MOVEM AC0,FS.FS ;SET IT UP
MOVX AC0,E.MFOP+E.FIDX ;MAKE AN ERROR NUMBER
TLON FLG1,FOPIDX ; REMEMBER IT'S A FILOP ERROR
MOVX AC0,E.MFOP+E.FIDA
TLNN FLG,IDXFIL ; ISAM FILE?
MOVX AC0,E.MFOP ; NO
MOVEM AC1,ULBLK.+1 ; [636] STORE ERROR CODE
PUSHJ PP,ERCDF ; IGNORE ERROR?
JRST RCHAN ; YES
JRST LUPERR ; NO
SUBTTL OPEN VERB TOPS-20 COMPT. UUO
IFN TOPS20,<
EXTERN CP.BLK,CP.BK1,CP.BK2,CP.BK3,CP.BK4,CP.BK5,CP.BK6,CP.BK7,CP.BK8
EXTERN FID.PT,FID.BK,TMP.BK,TMP.PT
; OPEN FILE VIA COMPT. UUO USING LONG FORM GTJFN
; IT IS USED FOR ALL BUT MTA FILES
; THIS ROUTINE BUILDS A PRIMARY STRING FROM THE VALUE OF ID
; IT ALSO BUILDS THE FOLLOWING DEFAULTS
; DEVICE FROM EITHER 1) [PPN] OR 2) SELECT CLAUSE
; <DIRECTORY> FROM [PPN]
; FILE NAME FROM PROGRAM NAME
; EXTENSION ONLY IF ISAM
; PROTECTION FROM PROTECTION CLAUSE
OCPT: TLNN FLG,IDXFIL ; [431] ISAM FILE?
JRST OCPTD ; [431] NO
PUSHJ PP,OPNLIX ; [431] YES, GET VID TO LOOKUP BLOCK
TLOA FLG1,FOPIDX ; [431] AN IDX FILE
OCPTD: PUSHJ PP,OPNLID ; [431] NO, GET VID...
;BUILD A TOPS20 FILE-DESCRIPTOR STRING - AC2 GTJFN BITS
;FIRST ZERO THE STORAGE AREAS
MOVE AC1,[FID.BK,,FID.BK+1] ; CLEAR ALL STUFF
SETZM FID.BK
BLT AC1,FID.BK+51 ;[1165] GET WHOLE FILE SPEC
MOVE AC1,[GJ.BLK,,GJ.BLK+1]
SETZM GJ.BLK##
BLT AC1,GJ.BLK+.GJJFN
MOVE AC0,[.NULIO,,.NULIO] ;NO INPUT TO OR FROM A FILE
MOVE AC1,[POINT 7,DF.NAM] ;SETUP THE DEFAULT FILENAME NAME
DMOVEM AC0,GJ.BLK+.GJSRC
;STORE THE DEVICE NAME IN SIXBIT IN THE COMPT. BLOCK
MOVE AC1,UOBLK.+1 ; GET THE DEVICE NAME
MOVEM AC1,CP.BK3 ; SET UP FOR COMPT. FUNCT 3--MAYBE
;AND AS AN ASCIZ STRING
MOVE AC5,[POINT 7,DF.DEV##]
MOVEM AC5,GJ.BLK+.GJDEV
OCPT01: SETZ AC0, ;INITIALIZE CHAR
LSHC AC0,6 ;GET NEXT ONE
ADDI AC0,40
IDPB AC0,AC5
JUMPN AC1,OCPT01
MOVEI AC0,":" ;END DEVICE WITH COLON
IDPB AC0,AC5
IDPB AC1,AC5 ;AND NULL
;THEN STORE PROTECTION FIELD AS ASCIZ STRING
HLRZ AC4,F.PROT(I16) ; DID USER SUPPLY PROTECTION CODE?
JUMPE AC4,OCPT6B ; NO
SKIPN (AC4) ; IS IT ZERO?
JRST OCPT6B ; YES, SO NO PROTECTION CODE
HRLI AC4,(POINT 3,0,17) ; FORM BYTE POINTER
MOVE AC5,[POINT 7,DF.PRO##]
MOVEM AC5,GJ.BLK+.GJPRO
MOVEI AC0,6 ; ALLOW SIX CHARACTERS
OCPT6A: ILDB C,AC4
ADDI C,"0"
IDPB C,AC5
SOJG AC0,OCPT6A ; LOOP FOR ALL 6
IDPB AC0,AC5 ; TERMINATE THE STRING
;NEXT CONVERT PPN TO STR:<DIRECTORY>
OCPT6B: HRRZ AC1,F.RPPN(I16) ; GET ADR OF PPN
JUMPE AC1,OCPT4 ; JUMP IF YOU HAVN'T GOT ONE
SKIPN @AC1 ; [463] SKIP IF YOU REALLY GOT ONE
JRST OCPT4 ; [463] PPN PROVIDED WAS [0,0]
MOVE AC2,(AC1) ; GET PPN FROM ADR
MOVE AC1,FID.PT ; GET POINTER TO TEMP FILE-DESCRIPTOR
HRROI AC3,DF.DEV ; POINTER TO DEFAULT DEVICE
PPNST% ; CONVERT [PPN] TO STRING
ERJMP RET.1
;NOW MOVE THE DEVICE TO DF.DEV AND RESET THE POINTER TO THE DIRECTORY
MOVE AC1,FID.PT ;POINT TO RETURNED STRING
MOVE AC5,[POINT 7,DF.DEV] ;POINT TO NEW DEFAULT DEVICE
OCPT1L: ILDB AC0,AC1
IDPB AC0,AC5
CAIE AC0,":"
JRST OCPT1L ;LOOP UNTIL END OF DEVICE
SETZ AC0,
IDPB AC0,AC5 ;STORE A NUL AT END OF STRING
MOVE AC5,[POINT 7,DF.DIR##] ;POINT TO DEFAULT DIRECTORY
MOVEM AC5,GJ.BLK+.GJDIR ;STORE POINTER TO DIRECTORY ONLY
IBP AC1 ;DELETE LEFT ANGLE BRACKET
OCPT1P: ILDB AC0,AC1
IDPB AC0,AC5
CAIE AC0,^O76 ;END OF DIRECTORY?
JRST OCPT1P ;NO
SETZ AC0, ;YES
DPB AC0,AC5 ;YES, STORE NUL OVER ANGLE
;NOW GET THE VALUE OF ID STRING
;IF IT IS EXACTLY 9 CHARACTERS WITH NO PERIOD THEN INSERT PERIOD AFTER 6 CHARS.
;OTHERWISE USE THE STRING AS IS. CONVERT IT TO ASCIZ THOUGH (MUST ADD A NULL).
OCPT4: TLNE FLG,IDXFIL ; [431] SKIP IF NOT ISAM FILE
TLNE FLG1,FOPIDX ; [431] SKIP IF ISAM .IDA FILE
SKIPA AC5,F.WVID(I16) ; [431] BYTE-PTR TO VALUE OF ID
JRST OCPT4A ;ISAM .IDA FILE WANTED
JUMPE AC5,OCPT2 ;NONE, USE DEFAULT
MOVE AC10,FID.PT ;GET STORAGE POINTER
LDB AC6,F.BSID ;GET SIZE OF VALUE OF ID
SKIPN AC6
MOVEI AC6,9 ;ASSUME 9 BY DEFAULT
;[1141]CONVERT SIXBIT OR EBCDIC FILENAME TO ASCII SO WE CAN SCAN IT FOR
;[1141]FILENAME SEPARATOR CHARACTERS
OPCT7: CAILE AC6,^D160 ;[1165] FILE ID CAN'T BE LONGER
MOVEI AC6,^D160 ;[1165] THAN 160 CHARACTERS
TLNN AC5,600 ; IS VID EBCDIC?
JRST OCPT7E ;YES
TLNN AC5,100 ;IS VID ASCII?
JRST OCPT7S ;NO, MUST BE SIXBIT
; JRST OCPT7A ;YES
OCPT7A: ILDB C,AC5 ;PICK UP A CHAR
IDPB C,AC10 ;STORE IN E BLOCK
SOSE AC0 ;[1165] CAN'T HAVE MORE THAN 160 CHAR
SOJN AC6,OCPT7A ;LOOP 'TIL
JRST OCPT7Z ;DONE
OCPT7E: ILDB C,AC5 ;PICK UP A CHAR
LDB C,PTR.97## ; CONVERT TO ASCII
IDPB C,AC10 ;STORE IN E BLOCK
SOSE AC0 ;[1165] CAN'T HAVE MORE THAN 160 CHAR
SOJN AC6,OCPT7E ;LOOP 'TIL
JRST OCPT7Z ;DONE
OCPT7S: ILDB C,AC5 ;PICK UP A CHAR
LDB C,PTR.67## ; CONVERT TO ASCII
IDPB C,AC10 ;STORE IN E BLOCK
SOSE AC0 ;[1165] CAN'T HAVE MORE THAN 160 CHAR
SOJN AC6,OCPT7S ;LOOP 'TIL DONE
OCPT7Z: SETZ C,
IDPB C,AC10 ;STORE NUL AT END
LDB AC6,F.BSID ;[1141]GET SIZE OF VALUE OF ID
SKIPN AC6 ;[1141]
MOVEI AC6,9 ;[1141]ASSUME 9 BY DEFAULT
CAIE AC6,9 ;[1141]IS IT 9 EXACTLY?
JRST OCPT2 ;[1141]NO, DONE - GO SET UP FOR GTJFN
;[1141]LOOK FOR SEPARATORS
;[1141]USE OLD METHOD IF NONE FOUND
MOVE AC10,FID.PT ;[1141]GET STORAGE POINTER
OCPTSP: ILDB C,AC10 ;[1141]PICK UP A CHAR
CAIE C,"." ;[1141]PERIOD?
CAIN C,":" ;[1141]OR COLON?
JRST OCPT2 ;[1141]YES DON'T CONVERT
CAIE C,^O74 ;[1141]LEFT ANGLE BRACKET?
CAIN C,"[" ;[1141]OR LEFT SQUARE BRACKET?
JRST OCPT2 ;[1141]YES DON'T CONVERT
CAIN C,";" ;[1141]OR MAYBE ";"
JRST OCPT2 ;[1141]YES DON'T CONVERT
SOJN AC6,OCPTSP ;[1141]LOOP TILL DONE OR SEPARATOR FOUND
;[1141]NO SEPARATOR. USE OLD METHOD.
MOVE AC5,F.WVID(I16) ;[1141]BYTE-PTR TO VALUE OF ID
MOVE AC10,FID.PT ;[1141]GET STORAGE POINTER
MOVEI AC6,9 ;[1141]LENGTH 9
JRST OCPT9 ;[1141]CONVERT AGAIN
;HERE FOR ISAM .IDA FILE
OCPT4A: MOVE AC5,[POINT 6,DFILNM(I12)]; [431] .IDA - SO VALUE-ID IS HERE
MOVE AC10,FID.PT ;GET STORAGE POINTER
MOVEI AC6,9 ;ASSUME 9 CHAR FOR NOW
;USE OLD METHOD BY DEFAULT
OCPT9: TLNN AC5,600 ; IS VID EBCDIC?
JRST OCPT9E ;YES
TLNN AC5,100 ;IS VID ASCII?
JRST OCPT9S ;NO, MUST BE SIXBIT
; JRST OCPT9A ;YES
OCPT9A: ILDB C,AC5 ;PICK UP A CHAR
CAIE C," " ;IGNORE SPACES
IDPB C,AC10 ;OTHERWISE STORE
CAIE AC6,4 ;IS IT TIME FOR "."?
SOJN AC6,OCPT9A ;NO, LOOP 'TIL DONE
JUMPE AC6,OCPT9Z ;[1141]ALL DONE
MOVEI C,"."
IDPB C,AC10
SOJN AC6,OCPT9A ;BACK FOR EXTENSION
JRST OCPT9Z ;[1141]DONE
OCPT9E: ILDB C,AC5 ;PICK UP A CHAR
LDB C,PTR.97## ; CONVERT TO ASCII
CAIE C," " ;IGNORE SPACES
IDPB C,AC10 ;STORE IN E BLOCK
CAIE AC6,4 ;IS IT TIME FOR "."?
SOJN AC6,OCPT9E ;NO, LOOP 'TIL DONE
JUMPE AC6,OCPT9Z ;[1141]ALL DONE
MOVEI C,"."
IDPB C,AC10
SOJN AC6,OCPT9E ;BACK FOR EXTENSION
JRST OCPT9Z ;[1141]DONE
OCPT9S: ILDB C,AC5 ;PICK UP A CHAR
LDB C,PTR.67## ; CONVERT TO ASCII
CAIE C," " ;IGNORE SPACES
IDPB C,AC10 ;STORE IN E BLOCK
CAIE AC6,4 ;IS IT TIME FOR "."?
SOJN AC6,OCPT9S ;NO, LOOP 'TIL DONE
JUMPE AC6,OCPT9Z ;[1141]ALL DONE
MOVEI C,"."
IDPB C,AC10
SOJN AC6,OCPT9S ;BACK FOR EXTENSION
OCPT9Z: SETZ C, ;[1141]
IDPB C,AC10 ;[1141]STORE NUL AT END
; NOW COMPLETE THE COMPT. UUO BLOCK
OCPT2: MOVX AC0,GJ%FOU ; SPECIFY THE LONG FORM & NEXT GENERATION
TXNN AC16,OPN%EX ; FILE MUST EXIST FOR OPEN EXTEND
TLNE FLG,IDXFIL!OPNIN ; ISAM FILE OR OPEN FOR INPUT?
TXC AC0,GJ%OLD!GJ%FOU ; YES, FILE MUST EXIST
MOVEM AC0,GJ.BLK+.GJGEN ; FLAGS FOR GTJFN JSYS
MOVEI AC0,GJ.BLK ; POINT TO ARG BLOCK
MOVE AC1,FID.PT ; [431] GET POINTER TO FILE DESCRIPTOR STRING
DMOVEM AC0,CP.BK1 ; [431] FOR GJGFN ARGUMENT
; SETUP THE FLAG BITS IN AC2 FOR OPENF
OCPT6: SETZ AC0,
TLNE FLG,DDMASC ; [431] DEVICE DATA MODE ASCII?
TXO AC0,7B5 ; [431] YES
TLNE FLG,DDMSIX ; [431] SIXBIT?
TXO AC0,6B5 ; [431] YES
TLNE FLG,DDMBIN ; [431] BINARY?
TXO AC0,44B5 ; [431] YES
TLNN FLG,DDMEBC ; [431] EBCDIC?
JRST OCPT10 ; [431] NO
TXO AC0,10B5 ; [431] ASSUME DEVICE IS A MAG-TAPE
TXNN AC13,DV.MTA ; [431] DEVICE A MTA?
TXO AC0,11B5 ; [431] NO, ITS A DSK
OCPT10: TLNE FLG,IOFIL!RANFIL!IDXFIL ; [622] [431] RANDOM,INDEXED OR IO FILES
TXO AC0,17B9 ; [431] ARE DUMP MODE
TLNE FLG,RANFIL!IDXFIL!OPNIN ; [622] [431] OPEN FOR INPUT?
TXO AC0,OF%RD ; [431] YES
TLNE FLG,OPNOUT ; [431] OPEN FOR OUTPUT?
TXO AC0,OF%WR ; [431] YES
SKIPN F.WSMU(I16) ;[667] SIMULTANEOUS UPDATE?
TXZA AC0,OF%THW ;[667] NO, CLEAR THAWED BIT
TXOA AC0,OF%THW ;[667] [431] THAWED I.E. SIMULTANEOUS UPDATE
TXNE AC16,OPN%EX ; IF OPEN EXTEND
TXO AC0,OF%RD!OF%WR ;[1131] TURN ON BOTH READ AND WRITE
TXNN AC0,OF%WR ;[1131] Is the write bit on?
TXO AC0,OF%RDU ;[667] TURN ON READ UNRESTRICTED ALSO
MOVEM AC0,CP.BK3 ; [431] INIT AC2 OPENF BITS
LDB AC0,F.BRMS ; IF ITS AN RMS FILE
JUMPN AC0,RET.2 ; RETURN TO RMSIO TO DO GETJFN
; [431]INITIALIZE TO TOPS-10 OPEN MODE
TLNE FLG,DDMASC ; [431] DATA-MODE ASCII?
TDZA AC0,AC0 ; YES
MOVEI AC0,.IOBIN ; [431] NOT ASCII
TLNE FLG,RANFIL!IDXFIL!IOFIL ; [622] [431] THESE FILES NOT BUFFERED
MOVEI AC0,.IODMP ; [431] DUMP MODE
; [431]LOCATE THE BUFFER HEADERS AND EXTENDED LOOKUP BLOCK
MOVEI AC1,D.IBH(I16) ; [431] INPUT BUFFER HEADER
DMOVEM AC0,CP.BK4 ; [431]
MOVEI AC0,D.OBH(I16) ; [431] OUTPUT BUFFER HEADER
MOVEI AC1,ARGBK. ; [431] ADR OF EXTENDED LOOKUP BLOCK
DMOVEM AC0,CP.BK6 ; [431]
; [431]SET UP EXTENDED LOOKUP BLOCK
HRRZ AC1,F.RPPN(I16) ; [431] GET ADR OF PPN
SKIPE AC1 ; [431] USE DEFAULT PPN IF ZERO
MOVE AC1,(AC1) ; [431] GET PPN
MOVEM AC1,ARGBK.##+.RBPPN ; [431] SETUP PPN
MOVE AC1,[ULBLK.,,ARGBK.+.RBNAM]; [431] COPY FILE-NAME.EXT
BLT AC1,ARGBK.+.RBEXT ; [431] FROM LOOKUP BLOCK
HLLZS ARGBK.+.RBEXT ; [431] CLEAR RIGHT HALF
SETZM ARGBK.+.RBPRV ; [431] AND PRIV
SETZM ARGBK.+.RBSIZ ; [431] AND SIZE
TLNE FLG1,FOPIDX ; [431] IF AN ISAM.IDX FILE GET CHAN #
SKIPA AC1,ICHAN(I12) ; [431] FROM HERE
LDB AC1,DTCN. ; [431] ELSE FROM HERE
HRLI AC1,CMP.1 ; [431] THE FUNCTION
TXNE AC16,OPN%EX ; HOWEVER OPEN EXTEND
HRLI AC1,CMP.13 ; NEEDS SPECIAL FUNCTION
MOVSM AC1,CP.BLK ; [431] ARG ,, FUNCTION
MOVE AC1,[10,,CP.BLK] ; [431] COUNT,,ADR FOR ARG-BLOCK
TXNE AC16,OPN%EX ; AGAIN OPEN EXTEND
HRLI AC1,11 ; HAS ONE MORE ARG (BUFFER NUMBER)
TXNE AC13,DV.LPT!DV.PTP ; SIMPLE DEVICE
JRST OPNATV ; YES, USE NATIVE MODE I/O
TXNE AC13,DV.MTA ; [1066] IS IT A LABELLED MTA?
PUSHJ PP,OCPT1A ; [1066] YES, GO SET UP ATTR. BLOCK
SETZM CMPTER## ;
;**;[1140] At OCPT10+55L
TXNN AC16,OPN%EX ;[1140] IF OPEN EXTEND
JRST NOXTND ;[1140] ELSE SKIP
PUSH PP,.JBFF ;[1140] SAVE .JBFF
HLRZ AC11,D.BL(I16) ;[1140] AND PNT IT TO BUFFER LOCATION
MOVEM AC11,.JBFF ;[1140] PA1050 MAKES BUFFER RING THERE
NOXTND: COMPT. AC1, ; [431] OPEN FILE
TDZA AC11,AC11 ;[1140] CLEAR AC11 TO FLAG FAILURE
SETOI AC11, ;[1140] ELSE, FLAG SUCCESS
TXNE AC16,OPN%EX ;[1140] OPEN EXTEND?
POP PP,.JBFF ;[1140] RESTORE END OF CORE PNTR
SKIPN AC11 ;[1140] SKIP RETURN IF SUCCESS
JRST [MOVEM AC1,CMPTER## ;SAVE ASIDE UUO ERROR CODE
POPJ PP,] ; [431] ERROR RETURN
TLZE FLG1,FOPIDX ; CLEAR FLAG, IF AN ISAM.IDX FILE
SKIPA AC2,ICHAN(I12) ; GET CHAN # FROM HERE
LDB AC2,DTCN. ; ELSE FROM HERE
PUSHJ PP,GETJFN ; GET THE JFN
SETZ AC1, ; FAILED, CANNOT HAPPEN
HRRM AC1,D.JFN(I16) ; STORE JFN
;THE FOLLOWING CHUNK OF CODE CHECKS FOR RELATIVE FILES OPENED UNDER SMU
; OPTION 1. IF A FILE DOES NOT HAVE THE MAXIMUM BYTE COUNT IN ITS FDB A
; WARNING MESSAGE IS ISSUED TO THE USER'S TERMINAL.
TLNE FLG,RANFIL ;IS IT RELATIVE FILE
TLNN FLG,OPNIO ; AND BEING OPENED FOR I-O?
JRST RET.2 ;NO
SKIPN F.WSMU(I16) ; UNDER SMU-OPTION 1?
JRST RET.2 ;NO
HRRZS AC1,AC1 ;MAKE SURE ONLY JFN IN AC1
HRLI AC2,1 ; WANT ONLY 1 WORD FROM FDB
HRRI AC2,.FBSIZ ; THE FILE SIZE
HRRZI AC3,AC0 ; PUT IT IN AC0
GTFDB ;GET THE FDB INFO
ERJMP [POPJ PP,] ; SHOULDN'T HAPPEN, TAKE ERROR RETURN
HRLOI AC2,377777 ;PUT MAX NO. OF PAGES IN AC2
CAMN AC0,AC2 ; SAME AS IN FDB?
JRST RET.2 ; YES
MOVE AC3,AC2 ;[1104] NO, PUT MAX BYTES IN AC3
HRLI AC1,BYTCTW ;[1104] BYTE COUNT WORD IN FILE'S FDB
SETO AC2, ;[1104] MASK FOR FULL WORD
CHFDB ;[1104] CHANGE FDB
ERJMP [POPJ PP,] ;[1104] TAKE ERROR RETURN
;[1104] PUSHJ PP,DSPL1. ;PUT OUT MESSAGE
;[1104] OUTSTR [ASCIZ /% /]
;[1104] MOVE AC2,[BYTE (5)10,31,20,14]
;[1104] PUSHJ PP,MSOUT1
;[1104] OUTSTR [ASCIZ / does not have the maximum file size
;[1104]in its FDB. Run SETEOF before updating to insure no loss of data under SMU.
;[1104] /]
JRST RET.2 ; [431] NORMAL RETURN
;[1066] This routine is used to set up the attribute block for the GTJFN jsys.
;[1066] The GTJFN call uses the attribute block when opening system labeled
;[1066] tapes. The format is set to D if the RECORDING MODE IS ASCII or
;[1066] if the RECORDING MODE IS STANDARD ASCII.
OCPTFO: ASCIZ/FORMAT:D/ ;[1066]
OCPT1A: PUSH PP,AC0 ;[1066]
HRRZ AC0,D.RFLG(I16) ;[1066] Get infomation flag
TXNN AC0,SASCII ;[1066] Recording mode ASCII ?
JRST OCPT1B ;[1066] No, exit
HRRI AC0,.GJATR-.GJJFN ;[1066] Get number of words
HRRM AC0,GJ.BLK+.GJF2 ;[1066] Set up number of extra
;[1066] words in GTJFN block.
MOVE AC0,GJ.BLK+.GJGEN ;[1066]
TXO AC0,GJ%XTN ;[1066] Set GJ%XTN in GTJFN block
MOVEM AC0,GJ.BLK+.GJGEN ;[1066]
HRROI AC0,GJ.ATR## ;[1066]
MOVEM AC0,GJ.BLK+.GJATR ;[1066] GTJFN points to attribute block
MOVEI AC0,2 ;[1066]
HRRM AC0,GJ.ATR ;[1066] Set number of words in attr.
MOVE AC0,[POINT 7,OCPTFO] ;[1066] Setup byte pointer in attribute
MOVEM AC0,GJ.ATR+1 ;[1066] block
OCPT1B: POP PP,AC0 ;[1066]
POPJ PP, ;[1066]
;Here to open simple devices in native mode
OPNATV: SOS D.OBH(I16) ; BACKUP TO FIRST WORD OF BUFFER AREA
DMOVE AC1,CP.BLK+1 ; GET GTJFN BITS
GTJFN%
POPJ PP, ; ERROR
HRRM AC1,D.JFN(I16) ; STORE JFN
DMOVE AC2,CP.BLK+3 ; GET OPENF BITS
OPENF%
POPJ PP, ; ERROR
TXO FLG1,B%NIO ; SIGNAL NATIVE I/O
SETO AC1,
DPB AC1,F.NIO ; MAKE A PERMANENT COPY OF FLG1
HLRZ AC1,D.FBS(I16) ; GET BUFFER SIZE IN WORDS
TLNE FLG,DDMASC ; DEVICE DATA MODE ASCII?
IMULI AC1,5 ; 5 BYTES PER WORD
TLNE FLG,DDMSIX ; SIXBIT?
IMULI AC1,6 ; 6 BYTES PER WORD
TLNE FLG,DDMEBC ; EBCDIC?
LSH AC1,2 ; 4 BYTES PER WORD
HRRM AC1,D.FBS(I16) ; STORE SIZE IN BYTES
JRST RET.2 ; OK
OCPER: SETZM FS.IF ; CLEAR .IDA FILE FLAG
MOVE AC1,CMPTER## ;GET ERROR CODE FROM COMPT. UUO
CAIN AC1,GJFX24 ; FILE NOT FOUND?
JRST OCPFNF ; NO, NOT FOUND.
CAIN AC1,OPNX9 ;[1147] Invalid Simul. Access error?
JRST [PUSHJ PP,SAVAC. ;[1147] yes
MOVEI AC2,3
JRST ENRAGN] ;[1147] Turn into file being modified error
MOVEI AC0,FS%30 ;[1054] FILL FILE-STATUS FOR PERMANENT ERROR
SKIPL WANT8. ;WANT 8x FUNCT?
JRST OCPERI ; NO
JRST OCPERJ ; YES, ON TO NEXT RAIN DANCE
OCPFNF: ;
HLLZ FLG1,D.F1(I16) ;GET FLG1 FLAGS
TXNE FLG1,B%OPTF ;IS FILE OPTIONAL?
JRST OCPEOP ; YES
MOVEI AC0,FS%30 ;SET PERMANENT ERROR
SKIPGE WANT8. ;WANT ANSI 8X USAGE?
MOVEI AC0,FS%35 ;YES, FILE NOT FOUND
JRST OCPERI ; NO
OCPEOP: ;
SKIPL WANT8. ;WANT ANS 8X USAGE?
POPJ PP, ; NO
MOVEI AC0,FS%05 ; YES, LET EM OFF EASY
MOVEM AC0,FS.FS ; SAVE FILE-STATUS ASIDE
MOVX AC0,E.MCPT ;SPECIFY COMPT. UUO
PUSHJ PP,IGCVR ; AND CONVERT IT INTO WORKING-STORAGE FIELD
TRN ; AND RETURN
POPJ PP, ; IN ANY EVENT
;CHECK ATTRIBUTE ERRORS ON OPEN.
OCPERJ: CAIN AC1,GJFX50 ;VARIOUS ERROR CODES FROM GETJFN RELATE TO STATUS
MOVEI AC0,FS%39 ;THEY INCLUDE GJFX45,46,47,49 AND 50
CAIL AC1,GJFX45 ; GJFX50 HAS TO BE TESTED SEPARATELY BECAUSE
CAILE AC1,GJFX49 ; ITS VALUE IS NOT CONTIGUOUS WITH THE
JRST OCPERI ; OTHERS.
CAIE AC1,GJFX48 ; ALSO, GJFX48 IS NOT AN ATTRIBUTE ERROR.
MOVEI AC0,FS%39
; JRST OCPERI
OCPERI: MOVEM AC0,FS.FS ;[1054] AND SAVE IT ASIDE
MOVX AC0,E.MCPT+E.FIDX ;[1054] MAKE AN ERROR NUMBER
TLZN FLG1,FOPIDX ; IDX OR IDA?
MOVX AC0,E.MCPT+E.FIDA ; IDA!
TLNN FLG,IDXFIL ; SKIP IF AN ISAM FILE
MOVX AC0,E.MCPT ; [431]
PUSHJ PP,IGCVR ; [431] IGNORE ERROR?
JRST RCHAN ; [431] YES
OCPERR: OUTSTR [ASCIZ /COMPT. UUO/]
JRST JSYSER ;PRINT REST OF MESSAGE
JFNSER: OUTSTR [ASCIZ /JFNS/]
JRST JSYSER ;PRINT REST OF MESSAGE
MTOERR: OUTSTR [ASCIZ /MTOPR/]
JRST JSYSER ;PRINT REST OF MESSAGE
CLSERR: OUTSTR [ASCIZ /CLOSF/]
JRST JSYSER ;PRINT REST OF MESSAGE
RLDERR: OUTSTR [ASCIZ /RELD/]
JRST JSYSER ;PRINT REST OF MESSAGE
OJFERR: OUTSTR [ASCIZ /OPENF/]
JRST JSYSER ;PRINT REST OF MESSAGE
STDERR: OUTSTR [ASCIZ /STDEV/]
JSYSER: OUTSTR [ASCIZ / failed /]
MOVEI AC1,.PRIIN ;
CFIBF% ; CLEAR TYPE AHEAD
MOVEI AC1,.PRIOU ;
DOBE% ;WAIT FOR PREVIOUS OUTPUT TO FINISH
HRROI AC1,[ASCIZ /
? JSYS error: /]
PSOUT%
MOVEI AC1,.PRIOU ;
HRLOI AC2,.FHSLF ; THIS FORK ,, LAST ERROR
SETZ AC3, ;
ERSTR% ; TYPE THE ERROR
JFCL
JFCL
; HRROI AC1,[ASCIZ /
;/]
; PSOUT% ; APPEND CRLF
MOVE AC2,[BYTE (5) 10,2,31,20,4]
JRST MSOUT. ; [431] FATAL ERROR MESSAGE
>; [431]END OF IFN TOPS20
;READ A LABEL FROM A MAGTAPE DEVICE. ***OPNBBF***
OPNRLB: TXNN AC13,DV.LPT!DV.TTY!DV.PTR!DV.PTP!DV.CDR ;[575]SKIP IF DEVICE IS ONE OF THESE
TXNN FLG1,B%STL ;SKIP IF LABELS ARE PRESENT
JRST OPNBBF ;
OPNRL2: TXNE AC16,OPN%RV ; OPEN INPUT REVERSED?
JRST OPNBBF ; YES, SKIP CHECK
PUSHJ PP,READSY ;READ A LABEL INTO THE BUFFER AREA
JRST OPNRL1 ;NORMAL RETURN
JRST OPNFW4 ;TRY AGAIN RETURN
OPNRL1: PUSHJ PP,BUFREC ;MOVE THE LABEL FROM THE BUFFER TO RECORD AREA
;DO BEFORE BEGINNING FILE USE PROCEDURE. PERFORM STANDARD
;LABEL CHECKS OR CREATE A LABEL. ***OPNABF***
OPNBBF: TLNE FLG,IOFIL!RANFIL!IDXFIL ;[622] SKIP IF NOT DUMP MODE
JRST OPNBB1 ;
TXNN AC16,OPN%EX ;OPEN EXTEND?
;BL; INSERTED AT OPNBBF+3 TO FIX OPEN-EXTEND BUG
JRST OPNBB3 ; NO, SKIP NULL-FILE TEST
HRRZ AC4,D.OBB(I16) ;NULL DESTINATION ADDR?
JUMPN AC4,OPNBB1 ; NO, DON'T NEED DUMMYOUT
OPNBB3:
TLNN FLG,OPNOUT ;[301] SKIP IF OUTPUT
JRST OPNBB1 ;[301] NOT OUTPUT,SKIP ENTER
IFN TOPS20,<
TXNN FLG1,B%NIO ;NATIVE I/O
JRST OPNBB2 ;NO
PUSHJ PP,WRTNIO ;YES, DO DUMMY OUTPUT (SET UP BUFFERS)
JRST OPNBB1
>
IFE TOPS20,<
TXNE AC13,DV.DIR ;[315] DIRECTORY DEVICE?
JRST OPNBB2 ;[315] YES, SKIP ENTER
PUSHJ PP,OPNEID ;[301] SET UP ID FOR ENTER
XCT UENTR. ;[301] DO AN ENTER
JRST OEERR ;[301] ERROR RETURN
>
OPNBB2: XCT UOUT. ;[315] DUMMY OUTPUT*******************
OPNBB1: TXNN AC13,DV.LPT!DV.PTR!DV.PTP!DV.TTY!DV.CDR ;NO LABELS - NO CHECKS
TXNN FLG1,B%STL ;SKIP IF LABELS ARE STANDARD
JRST OPNABF ;AFTER BEG FILE
TLNE FLG,OPNIN ;SKIP IF NOT INPUT / IO
JRST OPNCSL ;STANDARD LABEL CHECK
TXNE AC13,DV.MTA ;IF MTA
PUSHJ PP,OPNCAL ;CREATE A LABEL
;DO AFTER BEGINNING FILE LABEL PROCEDURE
;AND WRITE OUT THE LABEL. ***OPNENR***
OPNABF: TLNN FLG,OPNOUT ;OUTPUT SKIPS
JRST OPNDVC
TXNE AC13,DV.DIR ;SKIP IF NOT DIR. DEV. (I.E. DSK OR DTA)
JRST OPNENR
TXNN AC13,DV.LPT!DV.PTP!DV.PTR!DV.TTY!DV.CDR ;SKIP IF LPT,TTY,PTR,PTP,OR CDR.
TXNN FLG1,B%STL ;SKIP IF ANY LABELS
JRST OPNDVC ;NO LABELS
PUSHJ PP,RECBUF ;MOVE THE LABEL INTO THE BUFFER
SKIPGE FLG ;SKIP IF DEVICE IS NOT ASCII
PUSHJ PP,WRTCRLF ;
PUSHJ PP,WRTOUT ;WRITE THE LABEL
JRST OPNDVC
;DO AN ENTER AND SAVE THE FLAG REGISTER. ***EXIT TO THE ACP***
OPNENR: PUSHJ PP,OPNEID ;SETUP UEBLK. (DUMP-MODE)
IFN TOPS20,<
MOVE AC13,D.DC(I16) ;GET DEVCHR CHARACTERISTICS
>
TXNN AC16,OPN%EX ; APPEND MODE
IFN TOPS20,<
TXNN AC13,DV.MTA ;IF NOT MTA THEN WE HAVE USED THE COMPT. UUO
JRST OPNDVC
>
IFE TOPS20,<
JRST OPNEN0 ;[672] NO, GO ON
HLRZ AC13,UOBLK.+2 ;[672] IF THE APPEND FILOP
SKIPG 2(AC13) ;[672] DIDN'T SET UP BUFFER (NEW FILE)
JRST OPNEN1 ;[672] DO IT NOW
JRST OPNDVC ;[672] ELSE SKIP THE DUMMY OUT
OPNEN0: ;[672]
>
SKIPE F.WSMU(I16) ; SIMULTANEOUS UPDATE?
JRST OPNDVC ; [626]YES,SKIP THE ENTER AND THE DUMMY OUTPUT
XCT UENTR. ;ENTER - DIRECTORY DEVICE**********
JRST OEERR ;ERROR RETURN
OPNEN1: TLNN FLG,RANFIL!IOFIL!IDXFIL ;[622] DUMP MODE HAS NO DUMMY OUTPUTS
XCT UOUT. ;DUMMY OUTPUT*****ENTER VOIDS PREVIOUS DUMMY OUTPUTS.
OPNDVC: MOVEM FLG,F.WFLG(I16) ;UPDATE THE FLAGS
MOVE AC13,D.DC(I16) ;DEVCHR BITS
TXNE AC13,DV.TTY ;IS THIS A TTY FILE?
TXNN AC16,OPN%OU ;[642] AND OPEN FOR OUTPUT?
CAIA ;[642] NO, DON'T SET FLAG
HRRZM AC16,TTYOPN ;YES, REMEMBER THAT
TXNE FLG1,B%STL ;SKIP IF LABELS ARE OMITTED
PUSHJ PP,ZROREC ;CLEAR THE RECORD AREA I.E.LABEL
PUSHJ PP,CLRSTS ;[601] CLEAR FILE STATUS WORD
TLNN FLG,IDXFIL!RANFIL!OPNIN ;[622]
TLNN FLG,OPNOUT ;TEST FOR SEQ. OUTPUT
JRST OPNDV3 ;NO
SKIPN D.LCV(I16) ;LINAGE STUFF?
JRST OPNDV3 ;NO
HLRZ AC6,F.LAT(I16) ;LINES AT TOP?
JUMPE AC6,OPNDV3 ;ZERO
PUSHJ PP,WRTCRLF ;THERE ARE SOME
SOJG AC6,.-1 ;LOOP
OPNDV3: TXNN AC16,FL%WRC ;RESTORE THE REC-AREA IF A WRITE REEL CHANGE
JRST OPNDVR ;RETURN TO CBL-PRG
POP PP,AC2 ;FROM,,TO
POP PP,AC1 ;LENGTH
HRRZM AC2,.JBFF ;RESTORE FREE CORE
MOVSS AC2 ;THE OTHER WAY
ADDI AC1,(AC2) ;UNTIL
BLT AC2,(AC1) ;SLURP
OPNDVR: TXNE AC16,OPN%RV ;WANT READ BACKWARDS
TXNN AC13,DV.MTA ; AND HAVE A MTA
JRST OPNDVX ;NO, EXIT
; CHECK FOR MONITOR LABELS, ERROR IF SO
TLNN FLG1,MSTNDR ; IS MONITOR LABELING?
JRST OPDVRD ; NO CONT
; READ REVERSED NOT SUPPORTED WITH MONITOR LABELS
PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ/$ OPEN REVERSED is not supported with monitor labels./]
MOVE AC2,[BYTE (5)10,2,7,31,20,4]
PUSHJ PP,MSOUT. ; MESS OUT AND KILL.
; CHECK BLOCKING
OPDVRD: LDB AC1,F.BBKF ; FILE BLOCKED
SOJG AC1,OPDVRA ; GTR THAN 1?, IF SO JUMP
JUMPE AC1,OPDVRB ; JUMP IF BLOCKED 1 OK
; ERROR CASE, UNBLOCKED MTA READ REV
PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ/$ OPEN REVERSED is not supported for unblocked MTA./]
MOVE AC2,[BYTE (5)10,2,7,31,20,4]
PUSHJ PP,MSOUT. ; MESS OUT AND KILL.
OPDVRA: PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ/$ OPEN REVERSED not currently supported for blocking greater than 1 record./]
MOVE AC2,[BYTE (5)10,2,7,31,20,4]
PUSHJ PP,MSOUT. ; MESS OUT AND KILL.
; SET FLAG INDICATING READ REVERSED ACTIVE
OPDVRB: HRRZ AC1,D.RFLG(I16) ; GET SOME FLAGS
TRO AC1,RDDREV ; SET READ REVERSE OPEN ACTIVE
OPDVRC: HRRM AC1,D.RFLG(I16) ; AND PUT IT BACK
; IF POSITIONED FOR MULTI FILE TAPE, SKIP AHEAD TO EOF.
LDB AC1,F.BPMT ;POINT 6,6(I16),17 ... FILE POSITION ON REEL
JUMPE AC1,OPDVR0 ; JUMP IF NOT POSITIONED
OPDVR1: XCT MADVF. ; GO TO END OF FILE
XCT MWAIT. ; WAIT FOR COMPLETION
XCT MBSPF. ; BACKSPACE OVER EOF
XCT MWAIT.
JRST OPDVR9 ; OK, NOW SET READ REVERSED
; HERE IF NOT POSITIONED YET, IF BOT DO WHAT POSITIONED CASE DOES
OPDVR0: XCT MWAIT.
XCT SZBOT. ;STATZ BEG-OF-TAPE
JRST OPDVR1 ; BOT,ACT AS IN POSITIONED CASE
; NOT AT BOT,BACK ONE FILE, IF THEN NOT AT BOT, ASSUME OK
XCT MBSPF. ; BACKSPACE OVER EOF
XCT MWAIT.
XCT SZBOT. ; STATZ BEG-OF-TAPE
JRST OPDVR1 ; AT BOT, TOO BAD, REPOSITION FROM START
; NOW CHECK FOR LABELED CASE
TXNN FLG1,B%STL ;SKIP IF LABELS
JRST OPDVR9 ; NOP, ALL SET
XCT MBSPF. ; BACKSPACE OVER EOF, BETWEEN LABEL AND DATA
XCT MWAIT.
XCT SZBOT. ; STATZ BEG-OF-TAPE
JRST OPDVR1 ; AT BOT, TOO BAD, REPOSITION FROM START
; OK, WE SHOULD BE POSITIONED AT EOF , JUST BEFORE TAPE MARK
OPDVR9: MOVSI AC3,3 ; LENGTH,,ADDRESS
MOVEI AC0,.TFSET+.TFRDB ;FUNCTION
MOVE AC1,UOBLK.+1 ; DEVICE NAME
MOVEI AC2,1 ; INDICATE SET READ BACK
TAPOP. AC3,
JRST OMTA97 ; ERROR
OPNDVX: POPJ PP, ; NOW EXIT TO CBL-PRG
; THE FOLLOWING TABLES ARE USED TO SETUP THE CONVERSION INSTRUCTION
RCTBL: RCASC(AC2) ; ASCII TO ?
RCEBC(AC2) ; EBCDIC TO ?
RCSIX(AC2) ; SIXBIT TO ?
RCASC: MOVE C,CHTAB(C) ; ASCII TO ASCII
PUSHJ PP,RCAEC ;[542] EBCDIC
MOVS C,CHTAB(C) ; SIXBIT
RCEBC: LDB C,PTR.97## ; EBCDIC TO ASCII
TRN ; EBCDIC
LDB C,PTR.96## ; SIXBIT
RCSIX: ADDI C,40 ; SIXBIT TO ASCII
LDB C,PTR.69## ; EBCDIC
TRN ; SIXBIT
WCTBL: WCASC(AC1) ; ASCII TO ?
RCEBC(AC1) ; EBCDIC TO ?
RCSIX(AC1) ; SIXBIT TO ?
WCASC: TRN ; ASCII TO ASCII
LDB C,PTR.79## ; EBCDIC
MOVS C,CHTAB(C) ; SIXBIT
;[542] FOR ASCII TO EBCDIC WE NEED TO RETURN 1B0 FOR E-O-L CHARACTERS
RCAEC: SKIPGE CHTAB(C) ;[542] CHECK FOR E-O-L CHARACTER
JRST [LDB C,PTR.79 ;[542] YES, GET CONVERSION
TLO C,(1B0) ;[542] SET SIGN BIT
POPJ PP,] ;[542] RETURN
LDB C,PTR.79## ;[542] NORMAL, JUST GET CONVERSION
POPJ PP, ;[542] AND RETURN
;STANDARD LABELS AND INPUT OR IO
;CHECK THE VALUE OF ID. ***OPNABF***
OPNCSL: TXNE AC16,OPN%RV ; OPEN INPUT REVERSED?
JRST OPNABF ; YES, SKIP CHECK
TXNN AC13,DV.MTA ;IF NOT A MTA
JRST [PUSHJ PP,OPNLID ;JUST MOVE ID TO LOOKUP BLOCK
JRST OPNABF] ;AND CONTINUE
PUSHJ PP,RECSLB ;MOVE RECORD AREA TO STD-LABEL AREA
PUSHJ PP,OPNLID ;VALUE OF ID TO ULBLK.
;CHECK FOR LABEL TYPE 'HDR1'
MOVE AC0,STDLB. ;LABEL TYPE
TRZ AC0,7777 ;
CAMN AC0,[SIXBIT /HDR1/] ;SKIP INTO ERROR MESSAGE
JRST OPNCID ;CHECK VALUE OF ID
;MISSING OR WRONG LABEL TYPE
OUTSTR [ASCIZ/$ The beginning file label is missing./]
PUSHJ PP,SAVAC.
MOVE AC2,[BYTE(5)10,2,31,20,4,14]
PUSHJ PP,MSOUT.
JRST OPNFW4 ;TRY AGAIN
OPNCID: DMOVE AC0,STDLB. ;
HLL AC0,STDLB.+2 ;
ROTC AC0,30 ;JUSTIFY THE FILENAME
CAME AC0,ULBLK. ;CHECK FILE NAMES
JRST OPNIDE ;ID ERROR
HLLZ AC0,ULBLK.+1 ;
TRZ AC1,-1 ;CLEAR THE LABEL NUMBER
CAMN AC0,AC1 ;CHECK EXTENSIONS
JRST OPNCDW ;CHECK DATE WRITTEN
;ID ERROR.
OPNIDE: PUSHJ PP,SAVAC. ;
MOVE AC2,[BYTE (5)10,2,31,20,4,14]
PUSHJ PP,MSOUT. ;
OUTSTR [ASCIZ/$ The VALUE OF ID does not match the label ID./]
JRST OPNFW4
;CHECK DATE WRITTEN
OPNCDW: SKIPN AC6,F.WVDW(I16) ;VALUE OF DATE WRITTEN
JRST OPNCRN ;CHECK REEL NUMBER
MOVE AC0,[POINT 6,STDLB.+6,29]
MOVEI AC2,6 ;CHECK ONLY FIRST 6 CHARS.
OPNCD1: ILDB AC1,AC0 ;ONE FROM THE LABEL AND
ILDB AC5,AC6 ;ONE FROM THE FILE TABLE
TLNE AC6,100 ;SKIP IF SIXBIT OR EBCDIC
LDB AC5,PTR76.## ;MAKE ASCII INTO SIXBIT
TLNN AC6,600 ; EBCDIC?
LDB AC5,PTR96.## ; YES
CAME AC5,AC1 ;SKIP IF EQUAL
JRST OPNCD2 ;WRONG DATE MESSAGE
SOJN AC2,OPNCD1 ;LOOP 6 TIMES
JRST OPNCRN ; OK SO CHECK THE REEL NUMBER
;WRONG DATE
OPNCD2: MOVE AC2,[BYTE (5)10,31,20,2,4,14]
PUSHJ PP,MSOUT.
OUTSTR [ASCIZ /The file table date differs from the file label date./]
JRST KILL
;CHECK THE REEL NUMBER IF THE DEVICE IS A MAGTAPE
OPNCRN: TXNN AC13,DV.MTA ;MAGTAPE?
JRST OPNABF ;NO
HRL AC0,STDLB.+4 ;THE
HLR AC0,STDLB.+5 ; REAL
ROT AC0,-14 ; REEL
ANDI AC0,7777 ; NUMBER
LDB AC1,DTRN. ;AND WHAT IT OUGHT TO BE
CAMN AC0,AC1 ;SKIP IF UNEQUAL
JRST OPNABF ;MATCH
LDB AC2,F.BPMT ;
JUMPN AC2,OPNABF ;JUMP ITSA MULTI-FILE-REEL
PUSHJ PP,SAVAC. ;
OUTSTR [ASCIZ /
$/]
MOVE AC2,[BYTE(5)10,31,20,2,4,34,14] ;FODC.R#
PUSHJ PP,MSOUT. ;
OUTSTR [ASCIZ/ was mounted, please mount /]
PUSHJ PP,MSDTRN
OUTSTR [ASCIZ /
then/]
JRST OPNF04 ;TRY AGAIN
;CREATE A STANDARD LABEL. ***@POPJ***
OPNCAL: PUSHJ PP,OPNEID ;LOAD FILENM.EXT INTO ENTER BLOCK
PUSHJ PP,ZROSLA ;ZERO THE STD LABEL AREA
MOVE AC0,UEBLK. ;FILENAME
HLLZ AC1,UEBLK.+1 ;EXT
ROTC AC0,14 ;12 PLACES TO THE LEFT - MARCH.
TRO AC1,'1 ' ;FIRST LABEL
MOVEM AC0,STDLB.+1 ;FILE
HLLM AC1,STDLB.+2 ;DESCRIPTOR
TXNE AC16,V%OPEN!CLS%BV
HRLI AC1,'HDR' ;BEGINNING FILE LABEL
TXNE AC16,CLS%EF
HRLI AC1,'EOF' ;END OF FILE LABEL
TXNE AC16,CLS%EV
HRLI AC1,'EOV' ;END OF VOLUME LABEL
MOVEM AC1,STDLB. ;
PUSHJ PP,DATE. ;GET TODAY'S DATE (YYMMDD)
SETZ AC1, ;
ROTC AC0,6 ;
MOVEM AC1,STDLB.+6 ;CREATION
MOVEM AC0,STDLB.+7 ;DATE
OPNCA1: SETZ AC2,
LDB AC0,F.BPMT ;FILTAB FILE POSITION ON MAGTAPE
ROT AC2,6 ;
IDIVI AC0,^D10 ;
ADDM AC1,AC2 ;
JUMPN AC0,.-3 ;CONVERTED TO DECIMAL
ADD AC2,['0000'] ;SIXBITIZED
LDB AC1,DTRN. ;DEVTAB MAG-TAPE REEL NUMBER
ROT AC2,14 ;
ROTC AC1,-6 ;
ADDI AC1,'00 ' ;
DMOVEM AC1,STDLB.+4 ;REEL NUMBER AND FILE POSITION
SETZ AC1, ;
MOVE AC0,[SIXBIT /PDP10 /]
MOVEM AC0,STDLB.+12
HRLZ AC0,LIBVR.
ROTC AC0,14
ROT AC1,3
ROTC AC0,3
ROT AC1,3
ROTC AC0,3
ADDI AC1,'000'
HRLZM AC1,STDLB.+13 ;PDP10 VER
JRST SLBREC ;MOVE STD-LABEL TO RECORD AREA AND EXIT
OPNMTA:
;SET MAGTAPE DENSITY & PARITY
;POSITION MAGTAPE VIA FILE TABLE FILE POSITION. ***OPNLO***
; FIRST SET PARITY
XCT UGETS. ; GET STATUS INTO AC2
LDB AC5,F.BPAR ; GET REQUESTED PARITY
DPB AC5,[POINT 1,AC2,26]; SET PARITY
XCT USETS. ; SET STATUS
; CHECK FOR READ REVERSED SUPPORT
TXNN AC16,OPN%RV ; READ BACKWARDS?
JRST OMTA01 ; NO
HRLZI AC3,2 ; LENGTH ,, ADDR
MOVEI AC0,.TFKTP ; FUNCTION
LDB AC1,DTCN. ; GET MTA'S CHANNEL NUMBER
TAPOP. AC3, ; GET CONTROLER TYPE
JRST OMTA97 ; ERROR
CAIE AC3,.TFKTX ; NEED TX01(TU70/TU71)
CAIN AC3,.TFKTM ; OR TM02(TU16/TU45)
JRST OMTA01 ; OK
CAIE AC3,.TFKD2 ; SKIP IF DX20/TX02 CONTROLLER (OK TOO)
JRST OMTA97 ; NO
; NOW SET DENSITY AND HARDWARE DATA MODE
OMTA01:
IFN TOPS20,<
PUSHJ PP,MTASTS ; GET MTA STATUS INFO INTO TMP.BK
JRST OMTA91 ; ERROR RETURN
>
PUSHJ PP,SETDEN ; SET TAPE DENSITY
JRST OMTA95 ; ERROR, CAN'T SET DENISTY
IFN TOPS20,<
TLNE FLG1,MSTNDR ; IS MONITOR LABELING?
JRST OPNPMT ; YES, NO HARDWARE MODE SET ON TOPS20
; NOW GO SET TAPE POSITION
>
PUSHJ PP,SETHRD ; SET PROPER HARDWARE DATA MODE
JRST OMTA93 ; ERROR, CAN'T SET DATA MODE
JRST OPNPMT ; NOW GO SET TAPE POSITION
; SETHRD ROUTINE TO SET HARDWARE DATA MODE
;
; ARG AC16 ADDRESSES FILTAB, ASSUMES MTASTS HAS LEFT STATUS INFO
; IN TMP.BK FOR TOPS20
;
; RETURNS +1 IF ERROR
; +2 IF OK
; USES AC0-AC3
SETHRD: HRRZ AC1,D.RFLG(I16) ; GET STANDARD ASCII FLAG
TRNE AC1,INDASC ; IND-ASCII?
JRST STHRD2 ; YES
TRNN AC1,SASCII ; STD-ASCII REQUEST?
JRST STHRD1 ; NO
PUSHJ PP,STDASC ; YES,SET STD-ASCII
POPJ PP, ; ERROR, BAD RETURN
JRST RET.2 ; OK, GOOD RETURN
; CHECK FOR EBCDIC TAPE
STHRD1: TLNN FLG,DDMEBC ; RECORDING MODE EBCDIC?
; JRST RET.2 ; NO,DEFAULT OK, GOOD RETURN
JRST DEFMOD ;[1061] SET MODE TO CORE DUMP
TXNE FLG1,B%STL ; LABELS OMITTED?
JRST OMTA98 ; NO - ERROR
STHRD2: PUSHJ PP,INDCMP ; YES, SET INDUSTRY COMPATIBLE MODE
POPJ PP, ; ERROR, BAD RETURN
JRST RET.2 ; OK, GOOD RETURN
;[1061] HERE TO SET INDUSTRY COMPATIBLE CORE DUMP MODE
DEFMOD: HRLZI AC3,2 ;[1061] LENGTH,,ADDR
MOVEI AC2,.TFMID ;[1061] INDUSTRY-COMPATIBLE CORE DUMP MODE
JRST TAPMOD ;[1061] GO SET IT
;HERE TO SET INDUSTRY COMPATIBLE MODE
INDCMP: ; FIRST CHECK FOR PROPER MODE SUPPORT
; ON TOPS20 CHECK MODE SUPPORT IN STATUS BLOCK
IFN TOPS20,<
MOVE AC2,TMP.BK+.MODDM ; GET DATA MODES WORD (SET IN SETDEN)
TXNN AC2,SJ%CM8 ; IS IND-COMPT SUPPORTED?
POPJ PP, ; NO,ERROR RETURN
>; END IFN TOPS20
; ON TOPS10 CHECK FOR 9 TRACK TAPE
IFE TOPS20,<
LDB AC1,DTCN. ; GET MTA'S CHANNEL NUMBER
MTCHR. AC1, ; GET CHARACTERISTICS
SETZ AC1, ; ERROR RET - ASSUME 9TRK
TRNE AC1,MT.7TR ; 9 TRACKS?
JRST RET.2 ; NO, 7 TRACK, ALLOW DEFAULT-NON-IND-CMPT
>; END IFE TOPS20
; OK, SET INDUSTRY COMPATIBLE MODE
HRLZI AC3,2 ; LENGTH ,, ADDR
MOVEI AC2,.TFM8B ; INDUSTRY-COMPATIBLE MODE
PUSHJ PP,TAPMOD ; GO SET IT
POPJ PP, ; ERROR, BAD RETURN
JRST RET.2 ; OK, GOOD RETURN
; SET STD-ASCII HARDWARE DATA MODE
STDASC: MOVEI AC2,.TFM7B ; STANDARD ASCII MODE
PUSHJ PP,TAPMOD ; GO SET IT
POPJ PP, ; ERROR, BAD RETURN
JRST RET.2 ; OK, GOOD RETURN
; TAPMOD ROUTINE TO SET TAPE HARDWARE DATA MODE
;
; ARG AC2=DAT-MODE CODE TO BE SET
; USES AC0-AC3
; RETURNS +1 ERROR
; +2 OK
TAPMOD: HRLZI AC3,3 ; LENGTH ,, ADDR
MOVEI AC0,.TFSET+.TFMOD ; FUNCTION
MOVE AC1,UOBLK.+1 ; GET DEVICE NAME
TAPOP. AC3, ; CHANGE MODE
POPJ PP, ; ERROR - RETURN +1
JRST RET.2 ; OK, SKIP RETURN
; SETDEN ROUTINE TO CHECK AND SET TAPE DENSITY
;
; ARG AC16 ADDRESSES FILTAB, ASSUMES MTASTS HAS LEFT STATUS INFO
; IN TMP.BK FOR TOPS20
;
; RETURNS: +1 IF ERROR
; +2 IF OK, DENSITY IS SET
; USES AC0-AC3
SETDEN: LDB AC3,F.BDNS ; GET DENSITY REQUESTED
JUMPE AC3,RET.2 ; CORRECT RETURN IF DEFAULT USED
IFE TOPS20,<
; DO TAPOP TO CHECK POSSIBLE TAPE DENSITIES
HRLZI AC2,2 ; 2 ARGS START AT AC0
MOVEI AC0,.TFPDN ; FUNCTION TO READ POSSIBLE DENSITY
LDB AC1,DTCN. ; GET MTA'S CHANNEL NUMBER
TAPOP. AC2, ; READ POSSIBLE DENSITY
POPJ PP, ; ERROR, GIVE ERROR RETURN
>;END IFE TOPS20
IFN TOPS20,<
MOVE AC2,TMP.BK+.MODDN ; GET DENSITY CODES
LDB AC3,F.BDNS ; GET DENSITY REQUESTED
>;END IFN TOPS20
XCT DENTAB-1(AC3) ; TEST PROPER BIT
POPJ PP, ; ERROR, DENSITY NOT POSSIBLE
; SKIP RETURN, DENSITY POSSIBLE
; HERE IF DENSITY IS POSSIBLE, SET IT
MOVE AC2,AC3 ; REQUESTED DENSITY
HRLZI AC3,3 ; LENGTH,,ADR
MOVEI AC0,.TFSET+.TFDEN ; SET DENSITY FUNCTION
LDB AC1,DTCN. ; GET MTA'S CHANNEL NUMBER
TAPOP. AC3, ; SET IT
POPJ PP, ; ERROR, RETURN SUCH
;NOW GET/CHECK DENSITY
HRLZI AC3,2 ; LEN,,ADR
MOVEI AC0,.TFDEN ; GET DENSITY FUNCTION
LDB AC1,DTCN. ; GET MTA'S CHANNEL NUMBER
TAPOP. AC3, ; GET DENSITY
POPJ PP, ; ERROR, RETURN SUCH
CAME AC2,AC3 ; CHECK IT
POPJ PP, ; ERROR, RETURN SUCH
JRST RET.2 ; OK, ITS SET RIGHT GIVE OK RETURN
IFE TOPS20,<
; TABLE TO TEST RESULTS OF .TFPDN TAPOP
DENTAB: TXNN AC2,TF.DN1 ; TEST IF 200 BPI
TXNN AC2,TF.DN2 ; 556 BPI
TXNN AC2,TF.DN3 ; 800 BPI
TXNN AC2,TF.DN4 ; 1600 BPI
TXNN AC2,TF.DN5 ; 6250 BPI
>;END IFE TOPS20
IFN TOPS20,<
; DENTAB IS TABLE OF TESTS FOR .MOSTA MTOPR (AC0 HAS CODE RETURNED)
DENTAB: TXNN AC2,SJ%CP2 ; TEST IF 200 BPI
TXNN AC2,SJ%CP5 ; 556 BPI
TXNN AC2,SJ%CP8 ; 800 BPI
TXNN AC2,SJ%C16 ; 1600 BPI
TXNN AC2,SJ%C62 ; 6250 BPI
; MTASTS ROUTINE TO READ MTA STATUS INTO TMP.BK ON TOPS20
;
; ARG AC16 ADDRESSES MTA FILE TAB
;
; RETURNS +1 IF ERROR
; +2 IF OK, STATUS INFO IN TMP.BK
; USES AC0-AC3,TMP.BK
MTASTS: LDB AC2,UUOCHN ;GET CHANNEL NUM
PUSHJ PP,GETJFN ; GET JFN IN AC1
POPJ PP, ; ERROR RETURN
MOVEI AC2,.MODDM+1 ; LENGTH OF ARG BLOCK
MOVEM AC2,TMP.BK ; SET BLOCK LENGTH
SOJE AC2,MTSTSA ; LOOP ILL ARG BLOCK CLEAR
SETZM TMP.BK(AC2) ; CLEAR ARG WORD
JRST .-2 ; LOOP
MTSTSA: MOVEI AC2,.MOSTA ; GET TAPE STATUS FUNCTION
MOVEI AC3,TMP.BK ; ADDR OF ARG BLOCK
MTOPR% ; DO IT
ERJMP RET.1 ; IF ERROR EXIT ASSUMING IND-ASC
JRST RET.2 ; GOOD RETURN , STATUS IN TMP.BK
; HERE IF CAN'T GET MTA STATUS INFO
OMTA91: MOVX AC0,E.MTAP+FE%46 ; ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE THE ERROR?
JRST RCHAN ; YES
OUTSTR [ASCIZ /
? Unable to get mag tape status information./]
JRST OMTA99
>;END IFN TOPS20
;TAPOP. FAILED TO SET HARDWARE DATA MODE
OMTA93: MOVX AC0,E.MTAP+FE%45 ; ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE THE ERROR?
JRST RCHAN ; YES
OUTSTR [ASCIZ / TAPOP. failed - unable to set HARDWARE DATA MODE./]
JRST OMTA99
;TAPOP. FAILED OR "SET" DOESN'T MATCH "GET" DENSITY
OMTA95: MOVEI AC0,FE%47 ; ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE THE ERROR?
JRST RCHAN ; YES
OUTSTR [ASCIZ / Cannot set the requested density./]
JRST OMTA99
IFE TOPS20,<
;TAPOP. FAILED, CAN'T GET LABEL TYPE
OMTA96: MOVX AC0,E.MTAP+FE%48 ;ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE?
JRST RCHAN ; YES
OUTSTR [ASCIZ /
?TAPOP. failed - unable to get-set label type-information ./]
JRST OMTA99
VSWERR: MOVX AC0,E.MTAP+FE%56 ;ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE?
JRST RCHAN ; YES
OUTSTR [ASCIZ /
?TAPOP. failed - unable to switch mag tape reels ./]
JRST OMTA99
> ;END OF IFE TOPS20
;HERE IF READ BACKWARDS NOT SUPPORTED ON SPECIFIED MTA
OMTA97: MOVEI AC0,FE%57 ; ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE THE ERROR?
JRST RCHAN ; YES
OUTSTR [ASCIZ "
? Unable to set READ REVERSED ."]
JRST OMTA99
;FOR NOW EBCDIC FILES MUST HAVE OMITTED LABELS
OMTA98: PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /EBCDIC MTA files must have omitted labels./]
OMTA99: MOVE AC2,[BYTE (5) 10,31,20,2]
PUSHJ PP,MSOUT. ;DOESN'T RETURN
OMTA9A: PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /Internal error, MTA density code past 6250./]
JRST OMTA99 ; FINISH IT
; HERE TO POSITION MAG TAPE
OPNPMT: MOVEI AC3,2 ; 2 EOF'S PER FILE IF NOT EBCDIC
TLNE FLG,DDMEBC ; DEVICE DATA MODE EBCDIC?
MOVEI AC3,3 ; YES, 3 EOF/FILE.
TXNN FLG1,B%STL ; LABELS OMITTED?
MOVEI AC3,1 ; YES, 1 EOF/FILE.
MOVX AC5,B%HUF ;"HEAD UNDER THIS FILE" FLAG
LDB AC11,F.BPMT ;POINT 6,6(I16),17 ... FILE POSITION ON REEL
JUMPE AC11,OPNF00 ;JUMP IF MULTI REEL FILE WAS OPNREW
MOVE AC10,AC16 ;CURRENT FILE TABLE FIRST
OPNHUF: TDNE AC5,D.HF(AC10) ;SKIP IF NOT "HUF"
JRST OPNFND ;FOUND THE FILE
HRRZ AC10,11(AC10) ;NEXT FILE TABLE THAT SHARES THIS REEL
CAIE AC10,(I16) ;SKIP IF WE'VE MADE A COMPLETE LOOP
JUMPN AC10,OPNHUF ;ZERO=REEL NOT SHARED
;FALL THRU IF REEL NEVER POSITIONED
OPNREW:
IFN TOPS20,<
TXNN AC16,CLS%RO ;SKIP IF A CLOSE REEL GENERATED OPEN
TLNN FLG1,MTNOLB ;SKIP IF MOUNTR WITH NO LABELING
JRST OPNRWA ;OTHERWISE, GO ON
PUSH PP,AC3 ;SAVE SOME REGS
PUSH PP,AC5 ;
SETZ AC4, ;INDICATE GET FIRST REEL
PUSHJ PP,VOLSWT ;MAKE SURE FIRST REEL UP
POP PP,AC5 ;RESTORE SOME REGS
POP PP,AC3 ;
OPNRWA: >;END IFN TOPS20
PUSHJ PP,OPNRWD ;REWIND
SUBI AC11,1 ;SUB 1 FOR THIS REWIND
IMUL AC11,AC3 ; SEE HOW MANY EOF'S TO PASS
JUMPG AC11,OPNFWD
JRST OPNFW1
OPNRWD: XCT MWAIT.
XCT SOBOT. ;STATO BEG-OF-TAPE
XCT MREW. ;ELSE REWIND
POPJ PP,
SETBM: LDB AC5,F.BBM ;GET BYTE MODE FLAG
IFE TOPS20,<
TLNE FLG1,MSTNDR ; IF LABELED TOPS10 TAPE AND
TLNN FLG,DDMASC+DDMEBC ; IF ASCII OR EBCDIC THEN SET IT
>
JUMPE AC5,RET.1 ;NOT WANTED
IFE TOPS20,<
SETBM1: TRNN AC13,DV.M3 ;CAN IT SUPPORT MODE 3?
JRST SETBME ;NO
MOVEI AC5,.IOBYT ;YES
DPB AC5,[POINT 4,UOBLK.,35] ;[541] RESET MODE
POPJ PP, ;SUCCESSFUL RETURN
SETBME:
TLNE FLG1,MSTNDR ; IS IT LABELED TAPE?
POPJ PP, ; YES, NO MESSAGE NOW
MOVE AC2,[BYTE (5) 20,14] ;NO
PUSHJ PP,MSOUT. ;DEVICE
OUTSTR [ASCIZ / does not support BYTE MODE.
/]
POPJ PP, ;IGNORE
>
IFN TOPS20,<
OUTSTR [ASCIZ /
TOPS-20 does not support BYTE MODE.
/]
POPJ PP,
>
OPNFND: ANDCAM AC5,D.HF(AC10) ;CLEAR THE HUF FLAG
TXNN AC16,OPN%NR ;REWIND REQ?
JRST OPNREW ;YES
LDB AC10,[POINT 6,6(AC10),17] ;FIGURE OUT WHERE TO GO
SUB AC11,AC10 ;DIRECTION + MAGNITUDE
IMUL AC11,AC3 ; SEE HOW MANY EOF'S TO PASS
JUMPE AC11,OPNBOF ;GO TO THE BEG OF FILE
JUMPG AC11,OPNFWD ;SPACE FORWARD
OPNREV: XCT MWAIT. ;[336] MAKE SURE WE WAIT
XCT MBSPF. ;[336] BACKSPACE A FILE
XCT MWAIT. ;WAIT FOR COMPLETION
XCT SZBOT. ;STATZ BOT
JRST OPNRE1 ;PREMATURE BEG-OF-TAPE ERROR
AOJL AC11,OPNREV ;LOOP TILL (AC11)=0
OPNBOF:
IFN TOPS20,<
TLNE FLG1,MSTNDR ;SKIP IF NOT MONITOR LABELS
JRST OPNFW1 ;ELSE, SKIP THIS POSITIONING
>
XCT MBSPF. ;MOVE TO BEG OF CURRENT FILE
XCT MWAIT.
XCT SOBOT. ;SKIP, BIT=BOF
XCT MADVF. ;MOVE TO OTHER SIDE OF EOF MARK
JRST OPNFW1
OPNFWD: XCT MWAIT. ;AVOID POSITIONING ERRORS
XCT SZEOT. ;STATZ EOT
JRST OPNFW2 ;END OF TAPE ERROR
XCT MADVF. ;ADVANCE A FILE
SOJG AC11,OPNFWD
OPNFW1: XCT MWAIT. ;[336] WAIT ON MTA
ORM AC5,D.HF(I16) ;[336] NOTE CURRENT FILE OVER HEAD
TLNN FLG1,MSTNDR ; SYSTEM LABELS?
IFN TOPS20,<
JRST OMTA6E ; NO, CONT
>
IFE TOPS20,<
JRST OPNLO ; NO,CONT, NO FURTHER TESTS NEEDED
>
PUSHJ PP,MTALAB ; YES,GET LABEL INFO
JRST [ OUTSTR [ASCIZ /
?Internal error, MTALAB returned improperly./]
JRST OMTA99 ] ; FINISH IT
; HERE IF SYS-LABELED
IFE TOPS20,<
TLNN FLG,OPNOUT ; OPEN OUTPUT?
JRST OMTAIN ; NO, CONT OTHER CHECKS
; HERE FOR OPEN OUTPUT LABELED TOPS10
; SET LABEL INFO
PUSHJ PP,LBINFO ; WRITE TAPE LABEL INFO BLOCK
JRST OPNLO ; CONT
; LBINFO SETS LABEL INFORMATION BLOCK FOR PULSAR.
; FIRST IO DONE WILL CAUSE TAPE TO BE POSITIONED TO THE
; FILE INDICATED BY THIS INFO, FOR OUTPUT THIS INFO WILL
; BE WRITTEN INTO THE LABEL. COULD BE USED TO POSITION
; FOR READ ALSO, SKIPPING THE ABOVE OPNPMT POSITIONING
; CODE, THOUGH IT DOESN'T NOW.
; FIRST RESET THE ARG BLOCK TAPOP. WORKS, RESET BY MTALAB
LBINFO: LDB AC3,F.BLBT ; GET LABEL TYPE
MOVEI AC1,.TFLPR+.TFSET ; INDICATE FUNCTION "SET LABEL INFORMATION "
MOVEM AC1,TMP.BK+.TPFUN ;
MOVE AC1,UOBLK.+1 ; GET DEVICE NAME
MOVEM AC1,TMP.BK+.TPDEV ; SET IT
CAIE AC3,.TFLAL ; IS THE LABEL TYPE ANSI
CAIN AC3,.TFLAU ; OR ANSI WITH USER LABELS?
JRST OPC31B ; YES,JUMP
; NOT ANSI, ASSUME IBM
MOVE AC10,[POINT 8,TMP.BK+.TPFNM] ; GET BYT-PTR FOR FILNAM
TLNN FLG,DDMEBC ; IS DEVICE MODE EBCDIC?
JRST OPC31D ; NO, SET "U" FORMAT
MOVEI AC1,.TRFFX ; ASSUME FIXED FORMAT
JUMPGE FLG1,.+2 ; IS IT REALLY "V"
MOVEI AC1,.TRFVR ; YES, SET VARIABLE FORMAT CODE
MOVEM AC1,TMP.BK+.TPREC ; SET FORMAT INTO ARG-BLK
IFE TOPS20,<
PUSHJ PP,TPBTMD ; CHECK FOR BYTE MODE SET
>
JRST OPC31G ; NOW TRANSFER NAME TO ARG-BLK
; HERE TO SET "U" FORMAT, SINCE DDM DOES NOT CORRESPOND TO LABEL TYPE
OC31DA: HRRZ AC0,D.RFLG(I16) ; GET RUNTIME FLAGS
TRZ AC0,INDASC ; CLEAR ANY INDASC SETTING DONE AT RESET
HRRM AC0,D.RFLG(I16) ; PUT IT BACK
OPC31D: MOVEI AC1,.TRFUN ; GET "U" FORMAT CODE
MOVEM AC1,TMP.BK+.TPREC ; SET IT IN ARG BLOCK
JRST OPC31G ; GO WRITE FILNAME
; TPBTMD A ROUTINE TO CHECK BYTE MODE SETTING
IFE TOPS20,<
TPBTMD: TRNE AC13,DV.M3 ;CAN IT SUPPORT MODE 3?
POPJ PP, ; SUPPORT OK, RETURN
; HERE IF NOT SUPPORTED CHECK FOR EVEN RECORD CASE
MOVEI AC1,4 ; ASSUME 4 BYTES/WRD
MOVE AC0,D.RFLG(I16); GET RUNTIME FLAGS
TRNE AC0,INDASC ; IND-ASCII?
ADDI AC1,1 ; YES, MAKE THAT 5 BYTES/WRD
MOVE AC0,D.TCPL(I16) ; GET NUMBER BYTES IN LOGICAL BLOCK
IDIVI AC0,(AC1) ; SEE IF REMAINDER
JUMPE AC1,RET.1 ; NONE, SO OK, RETURN
; HERE IF MAY BE PADDING, ISSUE WARNING
MOVE AC2,[BYTE (5) 20,14] ;NO
PUSHJ PP,MSOUT. ;DEVICE
OUTSTR [ASCIZ / does not support BYTE MODE.
Tape may have records padded with nulls.
/]
POPJ PP, ;IGNORE
>; END IFE TOPS20
; HERE IF ANSI LABELS, OPEN OUTPUT
OPC31B: MOVE AC10,[POINT 7,TMP.BK+.TPFNM] ;GET PTR TO ARG-BLK
JUMPGE FLG,OC31DA ; JUMP IF DEVICE DATA MODE NOT ASCII
IFE TOPS20,<
PUSHJ PP,TPBTMD ; CHECK FOR BYTE MODE SET
>
MOVEI AC1,.TRFFX ; GET FIXED FORMAT CODE
HRLI AC1,.TFCAM ; ASSUME CRLF IN ASCII
HRRZ AC0,D.RFLG(I16) ; GET STANDARD ASCII FLAG
TRNE AC0,SASCII ; DOES HE WANT IT?
HRLI AC1,.TFCNO ; YES, THEN INDICATE NO CRLF
MOVEM AC1,TMP.BK+.TPREC ; SET FIXED FORMAT, AND FORMS CONTROL
TRNN AC0,SASCII ; WAS THAT STD-ASCII?
PUSHJ PP,CMPASC ; NO,MAKE SURE WE GET COMPATIBLE ASCII
LDB AC3,F.BLBT ; GET LABEL TYPE, LOST IN CMPASC
; HERE TO PUT VALUE-OF-ID INTO ARG-BLK
; AC10 HAS DESTINATION BYTE-PTR, AC3 HAS THE LABEL TYPE
OPC31G: PUSH PP,AC3 ; SAVE LABEL TYPE
PUSH PP,AC10 ; SAVE DESTINATION PTR
PUSHJ PP,OPNEID ; GET VALUE-OF-ID TO ENTER BLOCK
POP PP,AC10 ; RESTORE DESTINATION PTR
POP PP,AC3 ; RESTORE LABEL TYPE
MOVE AC5,[POINT 6,UEBLK.] ; GET BYT-PTR TO NAME
; CLEAR FILE NAME FIELD
MOVEI AC1,TMP.BK+.TPFNM+1 ; START OF NAME FIELD, + 1L
HRLI AC1,-1(AC1) ; FIRST WORD
SETZM -1(AC1) ; CLEAR FIRSTWORD
BLT AC1,.TPGEN+TMP.BK-1 ; CLEAR NAME FIELD
MOVEI AC1,6 ; START LOOP TO WRITE FILENAME
SETZ AC2, ; INDICATE THAT FILNAM FIRST
OPC31E: ILDB C,AC5 ; GET FILNAM CHAR
JUMPE C,OPC31C ; SKIP DEPOSIT IF SPACE SEEN
ADDI C,40 ; CONVERT TO ASCII
CAIL AC3,.TFLIL ; SKIP IF NOT EBCDIC
LDB C,PTR.79## ; ELSE, CONVERT TO EBCDIC
IDPB C,AC10 ; WRITE INTO ARG-BLK
OPC31C: SOJG AC1,OPC31E ; LOOP TILL FILNAM WRITTEN
JUMPL AC2,OPC31A ; JUMP IF FINISHED WITH EXTENSION
MOVEI AC1,3 ; SET FOR THREE EXTENSION CHARS
MOVEI C,"." ; GET DOT FOR EXTENSION
CAIL AC3,.TFLIL ; SKIP IF NOT EBCDIC
MOVEI C,113 ; ELSE, GET EBCDIC "."
IDPB C,AC10 ; WRITE IT
SETO AC2, ; INDICATE EXTENSION NOW
JRST OPC31E ; GO WRITE EXTENSION
; OK, NOW GO WRITE THE LABEL
OPC31A: LDB AC2,F.BMRS ; GET MAX RECORD SIZE
MOVEM AC2,TMP.BK+.TPRSZ ; SET LABEL RECORD SIZE
MOVE AC2,D.TCPL(I16) ; GET SIZE OF LOGICAL BLOCK
MOVEM AC2,TMP.BK+.TPBSZ ; SET LABEL BLOCK SIZE
MOVE AC1,[XWD .TPLEN,TMP.BK] ; INDICATE ARG-BLK
TAPOP. AC1, ; DO IT
JRST [ POP PP,(PP) ; POP RETURN
JRST OMTA96 ] ; AND GIVE ERROR SETTING LABEL INFORMATION
POPJ PP, ; RETURN
OMTAIN:
>; END IFE TOPS20
; HERE FOR SYS-LABELED CHECKS
JUMPL FLG,OMTA02 ; GO CHECK ASCII LABELED CASES
TLNN FLG,DDMEBC ; RECORDING MODE EBCDIC?
JRST OMTA06 ; NO
; SYSTEM LABELS, MUST BE EBCDIC, OR
; ELSE FOR INPUT THE FORMAT MUST BE "U" AND FOR OUTPUT
; THE FORMAT MUST BE SET TO "U"
LDB AC1,F.BLBT ; GET LABEL TYPE
IFN TOPS20,<
CAIN AC1,.LTEBC ; IS IT EBCDIC LABELS
>
IFE TOPS20,<
CAIE AC1,.TFLIL ; IS IT IBM?
CAIN AC1,.TFLIU ; OR IBM AND USER LABLES?
>
JRST OPNLO ; YES, ALL OK ,CONT
; LABEL TYPE DOES NOT MATCH RECORDING MODE, CHECK IT
IFN TOPS20,<
TLNN FLG,OPNIN ; OPEN FOR INPUT?
JRST OMTA0B ; NO, CHECK OUTPUT CASE
>
; OPEN INPUT, CHECK FORMAT IN LABEL
LDB AC1,F.BFMT ; GET LABEL FORMAT BITS
TXNE AC1,FRMATU ; "U" FORMAT?
JRST OPNLO ; YES, ALL OK, CONT
; ERROR, WRONG LABEL FORMAT
OMTA0E: MOVEI AC0,FE%52 ; INDICATE SEQ-OPEN ERROR
PUSHJ PP,IGCVR ; IGNORE ERROR?
JRST OPNLO ; YES, CONT ON, HE GETS WHAT HE WANTS
OUTSTR [ASCIZ/
?Improper tape label format for indicated recording mode./]
JRST OMTA99 ; GIVE REST OF MESSAGE AND KILL
; HERE TO CHECK ASCII RECORDING MODE MATCHES LABEL
OMTA02:
IFN TOPS20,<
TLNE FLG,OPNIN ; OPEN INPUT?
JRST OMTA03 ; NO,CHECK OUTPUT STATUS
>
LDB AC1,F.BLBT ; GET LABEL TYPE
IFN TOPS20,<
CAIE AC1,.LTANS ; IS IT ANSI LABELS
CAIN AC1,.LTT20 ; OR TOPS20 LABELS?
>
IFE TOPS20,<
CAIE AC1,.TFLAL ; IS IT ANSI?
CAIN AC1,.TFLAU ; OR ANSI AND USER LABLES?
>
JRST OPNLO ; YES, ALL OK ,CONT
LDB AC1,F.BFMT ; NO,GET LABEL FORMAT BITS
TXNE AC1,FRMATU ; "U" FORMAT?
JRST OPNLO ; YES, CONT
JRST OMTA0E ; NO,ERROR
; HERE TO CHECK OUTPUT ANSI-LAB ASCII
OMTA03:
IFN TOPS20,<
LDB AC1,F.BLBT ; GET LABEL TYPE
CAIE AC1,.LTANS ; IS IT ANSI LABELS
CAIN AC1,.LTT20 ; OR TOPS20 LABELS?
TRNA ; YES, SKIP
JRST OPNLO ; NO, CONT
PUSHJ PP,GETATB ; GET FILE ATTRIBUTES (IF ANY)
JRST OMTA04 ; NONE SET, CHECK FOR STD-ASCII
OMTA05: PUSHJ PP,SETFMT ; SET FORMAT FIELD
JRST OPNLO ; AND CONT
; SETFMT ROUTINE TO SET LABEL FORMAT BITS IN FILATB
;
; ARG AC5=FORMAT CHAR
; RETURNS +1 ALWAYS,AC1 HAS FORMAT BITS SET IN FILTAB
;
; USES AC1,AC5
SETFMT: SETZ AC1, ; CLEAR FORMAT BITS
CAIN AC5,"F" ; IS FORMAT "F"?
TRO AC1,FRMATF ; YES, SET IT
CAIN AC5,"U" ; IS FORMAT "U"?
TRO AC1,FRMATU ; YES, SET IT
CAIN AC5,"S" ; IS FORMAT "S"?
TRO AC1,FRMATS ; YES, SET IT
CAIN AC5,"D" ; IS FORMAT "D"?
TRO AC1,FRMATD ; YES, SET IT
DPB AC1,F.BFMT ; SET LABEL FORMAT BITS
POPJ PP, ; RETURN
; HERE IF NO ATTRIBUTE SET, CHECK FOR STD-ASCII
OMTA04: HRRZ AC0,D.RFLG(I16) ; GET FLAG
TRNN AC0,SASCII ; SKIP IF STD-ASCII
SKIPA AC5,["U"] ; ELSE ITS U FORMAT
MOVEI AC5,"D" ; ITS D FORMAT (SYS DEFAULT)
JRST OMTA05 ; GO SET FORMAT
>;END IFN TOPS20
; HERE FOR LABELED SIXBIT OR BINARY
OMTA06:
IFN TOPS20,<
TLNN FLG,OPNIN ; OPEN FOR INPUT?
JRST OMTA6A ; NO, CHECK OUTPUT CASE
>
; OPEN INPUT, CHECK FOR VALID LABEL TYPE (U)
LDB AC1,F.BFMT ; GET LABEL FORMAT BITS
TRNN AC1,FRMATU ; "U" FORMAT ?
JRST OMTA0E ; NO, ERROR BAD FORMAT
IFE TOPS20,<
JRST OPNLO ; YES, CONT
>
IFN TOPS20,<
JRST OMTA6B ; YES, CHECK DEFAULT DATA MODE FOR TROUBLE
; HERE FOR SIXBIT,BINARY OUTPUT
; CHECK THAT DEFAULT DATA MODE IS OK, CHANGE TO CORE DUMP IF NOT
OMTA6A:
PUSHJ PP,GETATB ; GET SET ATTRIBUTES
JRST OMTA6B ; NONE SET,CONT
PUSHJ PP,SETFMT ; SET FORMAT FIELD
TRNN AC1,FRMATU ; IS IT U FORMAT?
JRST OMTA0E ; NO,ERROR
JRST OPNLO ; YES, CONT
OMTA6B: PUSHJ PP,GTDFLT ; GET DEFAULT DATA MODE SETTING
CAIE AC3,.SJDMA ; IS IT ANSI-ASCII?
CAIN AC3,.SJDM8 ; OR INDUSTRY COMPATIBLE?
JRST OMTA6D ; YES,SKIP
JRST OPNLO ; ALL DONE, CONT
; HERE IF DEFAULT DATA-MODE WILL CAUSE PA1050 TO USE BAD BYTE SIZE
OMTA6D: MOVEI AC2,.TFMDD ; INDICATE SET CORE DUMP MODE
PUSHJ PP,TAPMOD ; GO SET IT
JRST OMTA93 ; ERROR, GO INDICATE SO
JRST OPNLO ; ALL DONE, CONT
; HERE IF TOPS20 UNLABELED
OMTA6E: TLNE FLG,OPNOUT ; OPEN OUTPUT?
TLNN FLG,DDMBIN+DDMSIX ; AND SIXBIT OR BINARY DEVICE MODE?
JRST OPNLO ; NO, ALL OK
; HERE IF UNLABELED OUTPUT SIXBIT-BINARY
PUSHJ PP,GTDFLT ; GET DEFAULT DATA MODE SETTING
CAIE AC3,.SJDM8 ; INDUSTRY COMPATIBLE DEFAULT?
JRST OPNLO ; NO, ALL OK
JRST OMTA6D ; YES, GO SET CORE DUMP MODE
; GETATB ROUTINE TO GET FILE FORMAT ATTRIBUTE THAT MIGHT BE SET
;
; RETURNS NON-SKIP IF NONE SET
; SKIP IF ATTRIBUTE SET, AC5=ATTRIBUTE CHAR
; (RIGHT JUSTIFIED)
; USES AC1-AC5
;
GETATB: LDB AC2,UUOCHN ; GET CHAN NUMBER FROM OPEN UUO XCT WRD
PUSHJ PP,GETJFN ; GET JFN IN AC1
JRST [OUTSTR [ASCIZ/
?OPEN MTA get JFN /] ;ERROR, ISSUE MESSAGE
JRST OCPERR] ;MORE MESSAGE AND KILL
MOVEI AC2,(AC1) ; GET JFN TO AC2
HRROI AC1,AC5 ; INDICATE WANT RESULTS IN AC5
MOVEI AC3,JS%AT1 ; INDICATE SINGLE ATTRIBUTE,AC4 HAS IT
MOVE AC4,[POINT 7,[ASCIZ /FORMAT/]] ;INDICATE WANT FORMAT VALUE
SETZ AC5, ; CLEAR DESTINATION
JFNS% ; RETURN ANY FORMAT ATTRIBUTE SET
ERJMP RET.1 ; ERROR, ASSUME IT IS NONE SET, RETURN
ROT AC5,^D7 ; ROTATE CHAR TO RIGHT POSITION
JRST RET.2 ; ELSE, GOT ONE IN AC5, GIVE GOOD RETURN
; HERE TO CHECK FOR ;FORMAT ATTRIBUTE "U" (TOPS20)
OMTA0B: PUSHJ PP,GETATB ; GET FILE FORMAT ATTRIBUTE
JRST OMTA0E ; NONE SET, GIVE ERROR
CAIE AC5,"U" ; IS FORMAT "U"?
JRST OMTA0E ; NO, GIVE ERROR
JRST OPNLO ; YES, OK, CONT
>;END IFN TOPS20
OPNF00: TXNE AC16,OPN%NR ;REWIND REQ ?
JRST OPNFW1 ;NO
JRST OPNREW ;YES
OPNRE1: OUTSTR [ASCIZ /$ Unexpected BOT marker/] ;[277]
JRST OPNFW5 ;
OPNFW2: SKIPL WANT8. ;WANT 8x FUNCT?
JRST OPNFW3 ; NO
MOVEI AC0,FS%36 ;SET UP F-S CODE FOR BAD MTA OPEN ON MULTI-FILE TAPE
MOVEM AC0,FS.FS ; AND SAVE IT ASIDE
PUSHJ PP,IGCVR ;REPORT IT
TRN ;IGNORE ERROR RETURN
OPNFW3: OUTSTR [ASCIZ /$ Unexpected EOT marker/] ;[277]
OPNFW5: PUSHJ PP,SAVAC.
OUTSTR [ASCIZ /$ encountered while positioning /]
MOVE AC2,[BYTE (5)10,31,20,14] ;FILE ON DEVICE.
PUSHJ PP,MSOUT.
OPNFW4: TXNN AC13,DV.DTA!DV.MTA ;SKIP IF A REEL DEVICE
JRST KILL ;
OUTSTR [ASCIZ /
If wrong reel please mount correct reel then /]
OPNF04: PUSHJ PP,C.STOP ;TYPE CONTINUE TO RETRY
PUSHJ PP,RSTAC.
MOVX AC5,B%HUF ;ANOTHER TAPE WAS MOUNTED
ANDCAM AC5,D.HF(I16) ;CLEAR THE "HEAD-UNDER-FILE" FLAG
JRST OPNBP4 ;TRY AGAIN
;PLACE VALUE OF ID IN LOOKUP/ENTER BLOCK
OPNLID: SKIPA AC10,[POINT 6,ULBLK.] ;LOOKUP SETUP
OPNEID: MOVE AC10,[POINT 6,UEBLK.] ;ENTER SETUP
TLNE FLG,IDXFIL ;ISAM ?
SKIPA AC5,[POINT 6,DFILNM(I12)]
SKIPE AC5,F.WVID(I16) ;BYTE POINTER TO VALUE OF ID
SKIPN AC5 ;GOT ONE?
SKIPA AC5,DF.PRG ;NO, USE PROGRAM NAME BY DEFAULT
PUSHJ PP,OPNVID ;[447]
SETZM ULBLK.+3 ;P,,P
SETZM UEBLK.+3 ;PROJ,,PROG
HLLZS ULBLK.+1 ;ZERO RIGHT HALF OF EXTENSION WORD
HLLZS UEBLK.+1 ; IN LOOKUP AND ENTER BLOCK
SETZM UEBLK.+2 ;CLEAR PROTECTION AND DATE
HLRZ AC5,F.PROT(I16) ; DID USER GIVE PROTECTION CODE
JUMPE AC5,OPNPPN ; NO
MOVE AC5,(AC5) ; YES, GET IT
DPB AC5,[POINT 9,UEBLK.+2,35] ;STORE FOR ENTER
OPNPPN: HRRZ AC5,F.RPPN(I16) ;ADR OF PROJ,,PROG
JUMPE AC5,RET.1 ;USE DEFAULT
MOVE AC5,(AC5) ;PROJECT,,PROGRAMER
IFE TOPS20,<
TLNE AC5,-1 ;[544] PROJECT#
TRNN AC5,-1 ;[544] OR PROGRAMMER # ZERO?
SKIPN AC5 ;[560] BUT NOT BOTH
JRST OPNPP1 ;[560] NO, DON'T DEFAULT
PUSH PP,AC5 ;[544] SAVE THIS PPN
GETPPN AC5, ;[544] GET DEFAULT
TRN ;[544] INCASE OF .JACCT
EXCH AC5,0(PP) ;[544] GET BACK THE USER NUMBER GIVEN
TLNN AC5,-1 ;[544] ZERO PROJ#?
HLL AC5,0(PP) ;[544] YES, FILL IN DEFAULT
TRNN AC5,-1 ;[544] ZERO PROG#?
HRR AC5,0(PP) ;[544] YES, FILL IN DEFAULT
POP PP,(PP) ;[544] FIXUP STACK
OPNPP1:>
MOVEM AC5,ULBLK.+3
MOVEM AC5,UEBLK.+3
POPJ PP, ;AND RETURN
OPNVID: MOVEI AC6,9 ;[444] ID HAS 9 CHARACTERS MAX
TLNN AC5,600 ; IS VID EBCDIC?
JRST OPNVIE ;YES
TLNN AC5,100 ;IS VID ASCII?
JRST OPNVIS ;NO, MUST BE SIXBIT
OPNVIA: ILDB C,AC5 ;PICK UP A CHAR
LDB C,PTR.76## ; CONVERT TO SIXBIT (TAKE CARE OF lower-case)
IDPB C,AC10 ;STORE IN E BLOCK
SOJN AC6,OPNVIA ;LOOP 11 TIMES
JRST OPNEI1 ;DONE
OPNVIE: ILDB C,AC5 ;PICK UP A CHAR
LDB C,PTR.96## ; CONVERT TO SIXBIT
IDPB C,AC10 ;STORE IN E BLOCK
SOJN AC6,OPNVIE ;LOOP 11 TIMES
JRST OPNEI1 ;DONE
OPNVIS: ILDB C,AC5 ;PICK UP A CHAR
IDPB C,AC10 ;STORE IN E BLOCK
SOJN AC6,OPNVIS ;LOOP 11 TIMES
OPNEI1: HLLZ AC6,-1(AC10) ;[563] GET LHS OF FILE NAME
JUMPN AC6,RET.1 ;[563] IF ZERO IT COULD BE CONFUSED WITH EXTENDED ENTER/LOOKUP ON TOPS-10
PUSHJ PP,DSPL1. ;[563] DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /?Illegal VALUE OF ID for/] ;[563]
MOVSI AC2,(BYTE (5) 10) ;[563] PRINT FILE NAME
PUSHJ PP,MSOUT1 ;[563] NEVER RETURNS
OPNLIX: MOVEI AC10,OPNLID
TRNA
OPNEIX: MOVEI AC10,OPNEID
TLC FLG,IDXFIL
PUSHJ PP,(AC10)
TLC FLG,IDXFIL
POPJ PP,
SUBTTL OPEN VERB USE procedure
;PERFORM A USE PROCEDURE
;CALLED WITH AN INDEX IN AC1, ***POPJ***
USEPRO: JUMPE AC1,USEPR0 ;JUMP IF ERROR USEPRO
TXNN FLG1,B%STL
POPJ PP, ;EXIT, THERE ARE NO LABELS
USEPR0: PUSHJ PP,SAVAC. ;SAVE THE ACS
PUSHJ PP,USESUP ;GET USE-PRO ADDRESS INTO AC1 AND AC2
TXNE AC16,CLS%EV!CLS%BV ;SKIP IF NOT A REEL PRO
JRST USEPR1 ;
LDB AC0,F.BPMT ;FILE POSITION ON MTA
JUMPN AC0,USEPR2 ;JUMP IF MULTI FILE REEL
TXNE AC16,CLS%EF ;SKIP IF AN OPEN USEPRO
USEPR1: PUSHJ PP,USESWP ;SET FOR REEL PROCEDURE
USEPR2: PUSHJ PP,USEXCT ;EXECUTE A PRO
MOVE AC16,-16(PP) ;RESTORE AC16
TXNN AC16,CLS%EV!CLS%BV ;EXIT IF A REEL PRO
SKIPN -1(PP) ;OR AN ERROR PRO
JRST RSTAC1 ;EXIT
PUSHJ PP,USESUP ;SETUP
TXNN AC16,CLS%EF ;SKIP IF A CLOSE TYPE USEPRO
PUSHJ PP,USESWP ;SET FOR REEL PROCEDURE
LDB AC0,F.BPMT ;FILE POSITION
JUMPN AC0,RSTAC1 ;EXIT, NOT A MULTI-REEL-FILE
PUSHJ PP,USEXCT ;ELSE PERFORM THE USE-PRO
JRST RSTAC1 ;@POPJ
; GENERAL (NON-FILE-SPECIFIC) USE PROCEDURES ARE ADDRESSED
; THROUGH A TABLE , WHOSE ADDRESS IS CONTAINED
; IN USES., WHICH IS DIVIDED INTO SECTIONS
; ACCORDING TO OPEN MODE. EACH SECTION IS 5 WORDS LONG
; WITH THE FOLLOWING FORMAT
;
; SECTION OFFSET USE PROCEDURE ADDRESS
;
; 0 ERROR
; 1 BEFORE BEGINNING
; 2 AFTER BEGINNING
; 3 BEFORE ENDING
; 4 AFTER ENDING
;
; EACH OF THE LABEL (68 ONLY) ENTRIES HAVE TWO ADDRESSES, THE
; REEL IN THE LEFT HALF AND THE FILE IN THE RIGHT
; (REEL-ADDR,,FILE-ADDR)
;
; THE SECTIONS ARE ORDERED INPUT,OUTPUT,I-O WITH EXTEND HAVING
; THE LAST ENTRY.
;
; FILE SPECIFIC USE PROCEDURE ADDRESSES ARE IN THE FILTAB, WITH
; 68 LABEL ADDRESSES IN THE SAME FORMAT AS ABOVE
USESUP: MOVE AC1,-2(PP) ;INDEX FOR THE USE TABLES
MOVEM AC1,AC2 ;
ADDI AC2,F.REUP(I16) ;ADR OF FILE USE PRO
ADD AC1,USES. ;ADR OF GENERAL USE PRO
MOVE FLG,-10(PP) ;RESTORE AC7
TLNN FLG,OPNOUT ;SKIP IF OUTPUT
JRST USESU1 ;INPUT USE PRO
HRRZ AC3,D.RFLG(I16) ; GET RUN FLAGS
TRNN AC3,EXTOPN ; WAS THIS OPENED EXTEND?
JRST USESU0 ; NO,CONT
ADDI AC1,EXTUSE ; SET EXTEND USE PROCEDURE OFFSET
JRST USESU1 ; AND CONT
USESU0: TLNE FLG,OPNIN ;SKIP IF NOT INPUT
ADDI AC1,USESEC ;INPUT/OUTPUT USE PRO,SKIP A SECTION
ADDI AC1,USESEC ;OUTPUT USE PRO, SKIP A SECTION
USESU1: MOVE AC1,(AC1)
MOVE AC2,(AC2)
SKIPN USES. ;
SETZ AC1, ;FOR STAND ALONE SORTS
POPJ PP, ;
USESWP: SKIPN -2(PP) ;IF ERROR USEPRO
POPJ PP, ; JUST RETURN
HLRZ AC1,AC1 ;USE THE REEL ADDRESS
HLRZ AC2,AC2 ;IN THE LEFT HALF
POPJ PP, ;
USEXCT: MOVE AC3,-2(PP) ;PP-2=AC1; USE TABLE INDEX
TRNE AC2,-1 ; IS THERE A FILE SPECIFIC USEPRO?
HRRZ AC1,AC2 ; YES,GET SPECIFIC FILTAB USEPRO
JUMPN AC1,USEXC1 ; NO,DEFAULTS TO GENERAL,GO PERFORM USEPRO
JUMPN AC3,USEXC2 ;IF NO LABEL USEPRO RETURN
AOSA -20(PP) ;IF NO ERROR USEPRO SKIP-EXIT
USEXC1: PUSHJ PP,(AC1) ;XCT THE USEPRO
USEXC2: POPJ PP, ;
;RECSLB.. MOVE RECORD AREA TO SIXBIT STD-LABEL AREA
;SLBREC.. MOVE SIXBIT STD-LABEL AREA TO RECORD AREA. ***POPJ***
RECSLB: TLOA AC0,400000 ;
SLBREC: TLZ AC0,400000 ;
MOVE AC2,STDLBP ; SET UP TO/FROM POINTERS
LDB AC1,[POINT 2,FLG,14] ; GET CORE DATA MODE
HLLZ AC1,RBPTBL(AC1) ; AND RECORD BYTE PTR
SKIPL AC0 ; WHICH WAY?
EXCH AC1,AC2 ; STD-LABEL TO RECORD AREA
MOVEI AC0,^D80-2 ;
TLNE FLG,DDMEBC ; EBCDIC ALWAYS HAS
MOVEI AC0,^D80 ; 80. CHARS
SLBRE1: ILDB C,AC1 ;
TLNE AC1,1000 ; EBCDIC TO SIXBIT?
LDB C,PTR.96## ; YES
TLNE AC2,1000 ; SIXBIT TO EBCDIC?
LDB C,PTR.69## ; YES
TLNN FLG,CDMSIX!CDMEBC ;
ADDI C,40 ; ASCII
IDPB C,AC2 ;
SOJG AC0,SLBRE1 ;
POPJ PP, ;;;;;
;READ THE LABEL INTO THE RECORD AREA. ***POPJ***
BUFREC: PUSHJ PP,BUFRE0 ;SETUP
MOVE AC10,D.RCNV(I16) ;SETUP AC10
BUFRE1: SOSGE D.IBC(I16) ;
PUSHJ PP,READSY ;FILL THE BUFFER
JRST BUFR01 ;NORMAL RETURN
JRST CLSRL0 ;EOF - COMPLAIN
BUFR01: ILDB C,D.IBB(I16) ;PICK UP A LABEL CHAR
XCT AC10 ;CONVERT IF NECESSARY
IDPB C,AC3 ;TO THE RECORD AREA
SOJG AC0,BUFRE1 ;LOOP TILL LABEL IS IN THE RECORD AREA
SETZM D.IBC(I16) ;THE BUFFER IS EMPTY
POPJ PP,
;WRITE OUT THE LABEL. ***POPJ***
RECBUF: PUSHJ PP,BUFRE0 ;SETUP
MOVE AC10,D.WCNV(I16) ;SETUP AC10
RECBU1: SOSGE D.OBC(I16)
PUSHJ PP,WRTOUT ;WRITE OUT THE BUFFER
ILDB C,AC3 ;PICK UP A LABEL CHAR
XCT AC10 ;CONVERT IF NECESSARY
IDPB C,D.OBB(I16) ;TO THE OUTPUT BUFFER
SOJG AC0,RECBU1 ;LOOP TILL DONE
POPJ PP,
;SET LABEL POINTER AND SIZE AND POPJ.
BUFRE0: LDB AC3,[POINT 2,FLG,14] ; GET CORE DATA MODE
HLLZ AC3,RBPTBL(AC3) ; AND THEN RECORD BYTE-PTR
MOVEI AC0,^D80-2 ;STD-LABEL SIZE
TLNE FLG,DDMEBC ; EBCDIC DEVICE?
MOVEI AC0,^D80 ; LABEL SIZE
TLNN FLG,DDMBIN ;IS FILE BINARY?
POPJ PP, ;NO
HRLZI AC3,(POINT 36,(FLG)) ;MAKE ONE BYTE BE ONE WORD
LDB AC10,[POINT 2,FLG,14] ; GET CORE DATA MODE
HRRZ AC10,RBPTBL(AC10) ; GET CHARS PER WORD
ADDI AC0,-1(AC10) ; -
IDIV AC0,AC10 ; TO WORD COUNT
POPJ PP,
;ZERO THE STANDARD LABEL AREA. ***POPJ***
ZROSLA: SETZM STDLB. ;
MOVEI AC1,STDLB.+1 ;TO
HRLI AC1,STDLB. ;FROM,TO
BLT AC1,STDLB.+15 ;ZERO 16 WORD STD LABEL AREA
POPJ PP,
;MOVE SPACES TO THE RECORD AREA. ***POPJ***
ZROREC: LDB AC2,[POINT 2,FLG,14] ; GET CORE DATA MODE
MOVE AC2,SPCTBL(AC2) ; GET A WORD OF SPACES
MOVEM AC2,(FLG) ; TO THE RECORD AREA
TXNN FLG1,B%STL ; STANDARD LABELS?
TDZA AC2,AC2 ; NO
MOVEI AC2,^D80 ; YES
LDB AC1,F.BMRS ;MAX REC SIZ
CAMGE AC1,AC2 ; USE THE LARGER SIZE
MOVE AC1,AC2 ; LABEL LARGER.
LDB AC2,[POINT 2,FLG,14] ; GET CORE DATA MODE
HRRZ AC2,RBPTBL(AC2) ; GET CHARS PER WORD
ADDI AC1,-1(AC2) ;CONVERT TO
IDIV AC1,AC2 ; WORDS
HRLI AC2,(FLG) ;THE FROM ADR
HRRI AC2,1(FLG) ;THE TO ADR
ADDI AC1,-1(FLG) ;THE UNTIL ADR
BLT AC2,(AC1) ;ZRAPP!
POPJ PP, ;
SPCTBL: ASCII / / ; ASCII SPACES
BYTE (9) 100,100,100,100 ; EBCDIC
SIXBIT / / ; SIXBIT
SPCTB1: 40 ; ONE ASCII SPACE RIGHT JUSTIFIED
100 ; EBCDIC
0 ; SIXBIT
;SAVE THE ACS ON THE PUSH DOWN STACK. ***"POPJ"***
SAVAC.: POP PP,TEMP. ;POP OFF THE RETURN
PUSH PP,AC16 ;SAVE AC16 - AC0
MOVEI AC16,15 ;
PUSH PP,(I16) ;
SOJGE AC16,.-1 ;
MOVE AC16,-16(PP) ;
JRST @TEMP. ;LAST ENTRY IS AC0
;RESTORE THE ACS. ***"POPJ"***
;RSTAC1 MUST -NOT- BE CALLED VIA PUSHJ
RSTAC1: HRRZI AC16,RET.1
MOVEM AC16,TEMP.
TRNA
;RSTAC. MUST BE CALLED VIA PUSHJ
RSTAC.: POP PP,TEMP. ;RESTORE AC0 - AC16
HRLZI AC16,-16 ;
POP PP,(I16) ;
AOBJN AC16,.-1 ;
POP PP,AC16 ;
JRST @TEMP. ;
;FREE THE IO CHANNEL. ***POPJ***
FRECH1: SKIPA AC2,ICHAN(I12) ;IDX-DEV'S CHAN
FRECHN: LDB AC2,DTCN. ;CHANNEL NUMBER
FRECH2: MOVNS AC2 ;SHIFT TO THE RIGHT
HRLZI AC0,400000 ;MASK BIT
LSH AC0,(AC2) ;POSITION THE MASK
ORM AC0,OPNCH. ;MAKES THE CHANNEL AVAILABLE
POPJ PP, ;
;DISTRIBUTE THE CHANNEL NUMBER THROUGH THE UUO TABLE. ***POPJ***
SETCN.: LDB AC5,DTCN. ; CHANNEL NUMBER
SETC1.: HRLZI AC10,ULEN.##-1 ; GET TABLE LENGTH
MOVE AC6,[POINT 4,UFRST.(AC10),12]
DPB AC5,AC6 ; INSERT THE CHAN NUMBER
AOBJN AC10,.-1 ; LOOP TILL THE LAST LOC
POPJ PP,
;RETURN A FREE CHANNEL NUMBER IN AC5
GCHAN: SKIPN AC5,OPNCH. ;ANY CHANNELS AVAILABLE?
SKIPA AC2,[BYTE (5)10,2,4,5] ;FCBO,TMOF.
SKIPA AC6,OPNCBP ;YES, SKIP + GET BYTE POINTER
JRST MSOUT. ;ERROR MESSAGE + KILL
HRRI AC5,1 ;[342] START WITH 1
MOVEI AC2,17 ;[342] UPPER LIMIT
GCHAN2: ILDB AC11,AC6 ;[342] GET FIRST CHAN FLAG
SOJE AC11,GCHAN1 ;[342] JUMP IF IT WAS A ONE
CAIG AC2,(AC5) ;[342] IF TRIED ALL 17
JRST GCHAN0 ;[342] THEN HAVE TO USE 0
AOJA AC5,GCHAN2 ;[342] AC5 (RIGHT) HAS CHAN NUMBER
GCHAN1: DPB AC11,AC6 ;[342] NOTE THAT CHAN UNAVAILABLE
POPJ PP,
GCHAN0: SETZB AC5,AC11 ;[342] USE CHANNEL 0
MOVE AC6,OPNCBP ;[342] MARK CHAN 0 IN USE
JRST GCHAN1 ;[342] AND EXIT
;INCREMENT THE REEL NUMBER BY ONE. ***POPJ***
INCRN.: LDB AC2,DTRN. ;SIXBIT ADD ONE TO CURRENT REEL NUMBER
MOVE AC0,AC2 ;SO THE REEL NUMBER MAY BE RESTORED
TRNE AC2,10
TRNN AC2,1 ;SKIP IF INC. WILL CAUSE A CARRY OUT
AOJA AC2,INCRN1 ;INCREMENT THE REEL NUMBER
TRNE AC2,1000
TRNN AC2,100
TRNA ;[327]
JRST INCRN2 ;99 IS MAX
ADDI AC2,100 ;[327] ADD 100
TRZ AC2,11 ;THE INCREMENT
INCRN1: DPB AC2,DTRN. ;SAVE AS CURRENT REEL NUMBER
POPJ PP,
INCRN2: MOVE AC2,[BYTE (5)10,31,20,2,4,14]
PUSHJ PP,MSOUT.
OUTSTR [ASCIZ /99 is the maximum acceptable reel number./]
JRST KILL
;OPEN FAILED - GIVE FATAL MESSAGE OR IGNORE IT
OERRDF: MOVX AC0,E.MOPE+E.FIDA ;ERROR NUMBER
SETZM FS.IF ;IDA FILE
JRST OERRI1 ;
;OPEN FAILED
OERRIF: MOVX AC0,E.MOPE+E.FIDX ;ERROR NUMBER
TLNN FLG,IDXFIL ;IDX FILE?
MOVX AC0,E.MOPE ;NO
OERRI1: PUSHJ PP,IGCVR ;IGNORE?
JRST RCHAN ;YES - NO MESSAGE BUT FILE IS NOT OPEN
MOVE AC2,[BYTE (5)25,4,20,13,23,15]
JRST MSOUT. ;DEVICE IS NOT A DEVICE OR NOT AVAILABLE
;RENAME OF "IDX" FILE FAILED
ORERRI: MOVX AC0,E.MREN+E.FIDX ;MAKE AN ERROR NUMBER
JRST OEERR1 ;
;RENAME FAILED
ORERR: SETZM FS.IF ;IDA FILE
MOVX AC0,E.MREN+E.FIDA ;ERROR NUMBER
TLNN FLG,IDXFIL ;IDX FILE?
MOVX AC0,E.MREN ;NO, ERROR NUMBER
JRST OEERR1 ;
;ENTER OF "IDX" FILE FAILED
OEERRI: MOVX AC0,E.MENT+E.FIDX ;ERROR NUMBER
JRST OEERR1 ;
;ENTER FAILED
OEERR: MOVEI AC0,FS%30 ;GET FILE-STATUS CODE = PERM. ERROR
MOVEM AC0,FS.FS ;SET IT UP
SETZM FS.IF ;IDA FILE
MOVX AC0,E.MENT+E.FIDA ;ERROR NUMBER
TLNN FLG,IDXFIL ;IDX FILE?
MOVX AC0,E.MENT ;NO, ERROR NUMBER
OEERR1: PUSHJ PP,ERCDE ;IGNORE?
JRST RCHAN ;YES
JRST ENRERR ;GIVE ERROR MESSAGE
;LOOKUP OF "IDX" FILE FAILED
OLERRI: MOVX AC0,E.MLOO+E.FIDX ;ERROR NUMBER
JRST OLERR1 ;
;LOOKUP FAILED
OLERR: SETZM FS.IF ;IDA FILE
MOVX AC0,E.MLOO+E.FIDA ;ERROR NUMBER
TLNN FLG,IDXFIL ;IDX FILE?
MOVX AC0,E.MLOO ;NO, ERROR NUMBER
OLERR1: PUSHJ PP,ERCDL ;IGNORE?
JRST RCHAN ;YES
JRST LUPERR ;GIVE ERROR MESSAGE
;GET THE LOOKUP/ENTER/RENAME/FILOP ERROR CODE INTO AC0
ERCDL: SKIPA AC1,ULBLK.+1 ;GET ERROR CODE FROM LOOKUP BLOCK
ERCDE: MOVE AC1,UEBLK.+1 ; OR ENTER BLOCK
ERCDF: ANDI AC1,37 ;GET ONLY THE ERROR BITS
CAIL AC1,10 ;DON'T CONVERT TO
ADDI AC0,2 ; DECIMAL
CAIL AC1,20 ; GET RID
ADDI AC0,2 ; OF 8, 9
CAIL AC1,30 ; 18, 19
ADDI AC0,2 ; 28 AND 29
ADD AC0,AC1 ;ADD IN THE ERROR CODE
CAIE AC1,6 ;HARDWARE ERROR?
JRST IGCVR ;NO
MOVEI AC1,FS%30 ;YES
MOVEM AC1,FS.FS ;LOAD FILE-STATUS
JRST IGCVR ;FINISH UP
;RELEASE THE IO CHANNEL AND NOTE THAT IT'S FREE
RCHAN: TLNN FLG,IDXFIL ;INDEXD FILE?
JRST RCHAN1 ;NO
HRRZ AC5,ICHAN(I12) ;GET THE CHANNEL NUMBER
PUSHJ PP,SETC1. ;SET UP THE RELEASE UUO
XCT URELE. ;RELEASE IT
PUSHJ PP,FRECH1 ; AND FREE THE CHAN
PUSHJ PP,SETCN. ;SET UP FOR THE "IDA" FILE
RCHAN1: XCT URELE. ;RELEASE IT
JRST FRECHN ;FREE THE CHAN AND RET TO CBL-PRG
PRGERC: ;FILE-STATUS CODE FOR CLOSE IF NOT OPEN
MOVEI AC0,FS%30 ; MAKE IT PERMANENT ERROR
MOVEM AC0,FS.FS ; AND SAVE IT FOR REPORTING
; JRST PRGERR ;DROP DOWN TO REGULAR REPORTING PROCEDURE
PRGERR: SETZM PRGFLG ;[1003] IN CASE FILE WAS CLOSED WITH DELETE
MOVX AC0,E.VCLO+FE%20 ;ERROR NUMBER
MOVE AC2,[BYTE(5)10,31,20,37,33]
;CALL VIA JRST
;AC0 HAS ERROR NUMBER FOR IGCV - AC2 HAS ERROR MESSAGE FOR MSOUT.
OXITER: TLNE FLG,IDXFIL ;ISAM FILE?
ADD AC0,[E.FIDX] ;YES
PUSHJ PP,IGCV ;IGNORE ERROR?
JRST MSOUT. ;NO
POPJ PP, ;YES, BACK TO MAIN LINE
;CALL VIA PUSHJ -- AC0 HAS ERROR NUMBER
OXITP: TLNE FLG,IDXFIL ;ISAM FILE?
ADD AC0,[E.FIDX] ;YES
PUSHJ PP,IGCVR ;IGNORE ERROR ?
POP PP,(PP) ;YES, POP OFF RETURN
POPJ PP, ; RETURN
;FILE ALREADY OPEN
OPNFAO: HRLZI AC2,(BYTE (5)10,2,3) ;FCBO,AO.
MOVEI AC0,FS%41 ;8x FILE-STATUS NUMBER
MOVEM AC0,FS.FS ;SAVE FILE-STATUS FOR REPORTING
MOVEI AC0,FE%10 ;FILE STATUS ERROR NO.
JRST OXITER ;ONLY CLOSED FILES MAY BE OPENED
;FILE ALREADY LOCKED
OPNFAL: MOVEI AC0,FS%38 ;8x FILE-STATUS CODE
MOVEM AC0,FS.FS ;SAVE FILE STATUS FOR REPORTING
MOVEI AC0,FE%11 ;ERROR NUMBER
PUSHJ PP,OXITP ;DOESN'T RETURN IF IGNORING ERRORS
OUTSTR [ASCIZ /LOCKED /]
HRLZI AC2,(BYTE(5)10,2,4)
JRST MSOUT. ;EXIT, THE FILE IS LOCKED
;DEVICE NOT AVAILABLE TO JOB
OPNDNA: MOVE AC2,[BYTE (5)10,2,4,20,15] ;FCBO,DINATTJ.
MOVEI AC0,FE%13 ;ERROR NUMBER
JRST OXITER ;COMPLAIN
;IF CHECKPOINT MODE IS REQUIRED SET BIT IN OPEN BLOCK
IFE TOPS20,<
OPNCKP: LDB AC1,F.BCKP ;IS RIB UPDATE REQUIRED
JUMPE AC1,RET.1 ;NO
MOVX AC1,UU.RRC ;OPEN RIB UPDATE FUNCTION
IORM AC1,UOBLK. ;YES, SET IT
POPJ PP,
>
;IF PADDING CHAR IS SUPPLIED SET UP THE CORRECT RUNTIME ONE TO MATCH OUTPUT TYPE.
SETPAD: TLNE FLG,DDMBIN ;NO PADDING FOR BINARY FILES?
POPJ PP, ; SO RETURN (IS THIS RIGHT?)
MOVE AC1,F.PADD(I16) ;GET BYTE POINTER
TLNN AC1,-1 ;IS AN ASCII LITERAL?
SKIPA C,AC1 ;YES, GET IT
ILDB C,AC1 ;NO, GET SINGLE CHAR
LDB AC2,[POINT 6,AC1,11] ;GET BYTE SIZE
LDB AC1,[POINT 2,FLG,2] ;GET DEVICE DATA MODE
SKIPN AC2 ;CONVERT ASCII LITERAL
MOVEI AC2,7 ;TO ASCII SIZE
ANDI AC2,3 ;WE WANT TO TURN S=6, A=7, E=9
TRC AC2,3 ;INTO A=0, S=1, E=2
XCT @WCTBL(AC2) ;CONVERT CHAR
DPB C,[F%PADD] ;AND STORE IT FOR EASY ACCESS
POPJ PP, ;RETURN
SUBTTL WRITE OUT THE BUFFER
;ALL BUFFERED OUTPUTS ARE DONE HERE. ***POPJ***
WRTOUT: SKIPG D.OE(I16) ;[470] FIRST OUTPUT?
JRST CHKLOK ;[470] YES, CHECK IF DEVICE WRITE-LOCKED
WRTOT1: AOS D.OE(I16) ;BUMP OUTPUT COUNT
IFN TOPS20,<
TXNE FLG1,B%NIO ;WANT NATIVE I/O?
JRST WRTNIO ;YES
>
XCT UOUT. ;DO THE OUTPUT
PUSHJ PP,CKFOD ;NORMAL RETURN, SEE IF CHECKPOINT REQUIRED
; DOES NOT RETURN UNLESS ERROR
WRTWAI: XCT UWAIT. ;FOR ALL THE ERRORS
XCT UGETS. ;
TXNE AC2,IO.ERR ;ERRORS?
JRST WRTERR ;THERE ARE ERRORS.
MOVE AC13,D.DC(I16) ; GET DEVICE CHARACTERISTICS
TXNE AC13,DV.MTA ;MTA?
TXNN AC2,IO.EOT ;EOT?
JRST WRTXTN ;NOT A MAGTAPE EOT
TXNE AC16,V%READ!CLS%EF!CLS%EV ;CLOSE OR READ?
JRST WRTXIT ;YES TYPE 'F' OR 'R' LABEL OR READ
LDB AC0,F.BPMT ;COULD BE WRITE, OPEN, OR CLOSE 'B'
JUMPN AC0,WRTMFR ;JUMP IF MFR
TXO AC16,FL%EOT ;EOT FLAG
; CLEAR STATUS ONLY FOR 10
IFE TOPS20,<
JRST WRTXIT ;
>
IFN TOPS20,<
POPJ PP, ;
>
WRTMFR: MOVE AC0,[E.MOUT] ;OUTPUT ERROR
PUSHJ PP,IGMDR ;IGNORE ERROR?
JRST WRTXIT ;YES
PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ/Encountered an "EOT" on a multi file reel while processing/]
MOVE AC2,[BYTE(5)10,31,20,36]
JRST MSOUT. ;/FILE ON DEVICE/ KILL
;READ EOF GETS A SKIP EXIT
WRTRSX: TLO FLG,ATEND ;SET READ AN "EOF"
TXNN AC16,V%READ ;SKIP IF ITS A READ
JRST WRTRS1 ;DON'T SET ERROR STATUS IF A WRITE
PUSHJ PP,SETS10 ;SET FILE-STATUS IF REQUIRED
TRN
WRTRS1: AOS (PP) ;SKIP EXIT VIA WRITE EXIT
WRTXIT: XCT UGETS. ;GET STATUS
TXNE AC13,DV.MTA ;MAGTAPE?
TXZA AC2,IO.ERR!IO.EOF!IO.EOT ;MAGTAPE.
WRTXTN: TXZE AC2,IO.ERR!IO.EOF ;OTHER.
XCT USETS. ;SET STATUS
POPJ PP, ;RETURN
;HERE FOR NATIVE MODE I/O
IFN TOPS20,<
WRTNIO: PUSH PP,AC1 ; JUST TO BE SURE
PUSH PP,AC2
PUSH PP,AC3 ; THIS NEEDS TO BE SAVED FOR SURE
HRRZ AC2,D.OBH(I16) ; START OF BUFFER
HLL AC2,D.OBB(I16) ; BYTE SIZE
TLZ AC2,770000 ; CLEAR JUNK
TLO AC2,440000 ; POINT TO START
MOVEM AC2,D.OBB(I16) ; RESET IT
HRRZ AC1,D.FBS(I16) ; GET BUFFER SIZE
MOVE AC3,D.OBC(I16) ; GET COUNT OF WHATS LEFT
SUB AC3,AC1 ; NEGATIVE NO. OF BYTES
MOVEM AC1,D.OBC(I16) ; RESET COUNT
SKIPGE D.OBH(I16) ; INITIAL DUMMY OUTPUT?
JRST [HRRZS D.OBH(I16) ;YES, CLEAR VIRGIN BIT
JRST WRTNI1] ;AND RETURN
HRRZ AC1,D.JFN(I16) ; GET JFN
SOUT%
ERJMP WRNTER
WRTNI1: POP PP,AC3
POP PP,AC2
POP PP,AC1
POPJ PP,
WRNTER: HALT
>
;[470] HERE TO CHECK IF DEVICE IS WRITE-LOCKED ON FIRST OUTPUT
CHKLOK: TXNN AC13,DV.MTA ;[470] MTA?
JRST WRTOT1 ;[470] NO
XCT MERAS. ;[470] TO DETERMINE IF TAPE IS WRITE-LOCKED
XCT MWAIT. ;[525] CHECK FOR WRITE LOCK ERROR
XCT UGETS. ;[470] GET STATUS
TXNN AC2,IO.IMP ;[470] WRITE-LOCKED?
JRST WRTOT1 ;[470] NO, OK TO DO OUTPUT
WRTERR: TXNE AC13,DV.MTA ;MTA?
TXNN AC2,IO.IMP ;WRITE-LOCKED?
JRST WRTER1 ;NO
TXC AC2,IO.ERR ;
TXCN AC2,IO.ERR ; IS THIS A MTA LABEL PROCESSING ERROR?
JRST WRTER1 ; YES - CATCH IT AT IOERMS
PUSHJ PP,SAVAC. ;IT'S A WRITE-LOCKED MAGTAPE
OUTSTR [ASCIZ /$ /]
MOVE AC2,[BYTE(5)22,27,10,31,20,4,14]
PUSHJ PP,MSOUT. ;"CANNOT DO OUTPUT TO <DEVICE><FILE>
OUTSTR [ASCIZ/Is the device write enabled?/]
PUSHJ PP,C.STOP ;"TYPE CONTINUE TO PROCEDE"
PUSHJ PP,RSTAC. ;RESTORE THE ACS
TXZ AC2,IO.ERR!IO.EOF ;TURN OFF THE ERROR BITS
XCT USETS. ;SET STATUS
JRST WRTOUT ;[525] TXY AGAIN
WRTER1: MOVE AC0,[E.MOUT] ;OUTPUT ERROR
PUSHJ PP,IGMDR ;IGNORE ERROR?
JRST WRTXIT ;YES
MOVE AC2,[BYTE(5)36,31,20,10,4,14]
PUSHJ PP,MSOUT. ;"OUTPUT ERROR ON <DEVICE><FILE>"
PUSHJ PP,IOERMS ;THE ERROR
JRST KILL ;
IOERMS: XCT UGETS. ;GET STATUS AC2*************
IOERM1: TXC AC2,IO.ERR ;
TXCE AC2,IO.ERR ; IS THIS A MTA LABEL PROCESSING ERROR?
JRST IOERM2 ; NO
HRLZI AC3,2 ; LENGTH ,, ADDRESS
MOVEI AC0,.DFRES ; FUNCT - EXTENDED IO ERRORS
MOVE AC1,D.ICD(I16) ; ADDRESS OF
MOVE AC1,(AC1) ; SIXBIT /DEVICE/
DEVOP. AC3, ; GET ERROR CODE
SETZ AC3, ; "ERROR" GETTING ERROR CODE!
OUTSTR [ASCIZ / Monitor label processing failed ./]
PUSHJ PP,ERCODE ; OUTPUT ERROR STATUS
MOVEI C," "
OUTCHR C ; TYPE A SPACE
CAIG AC3,LTCLEN ; SKIP IF NO TEXT FOR THIS CODE
JRST IOERM3 ;
OUTSTR [ASCIZ / There is no text for this error code./]
POPJ PP,
IOERM3: OUTSTR @LTCTBL(AC3) ; EXPLAIN THE CODE
POPJ PP,
IOERM2: PUSHJ PP,ERCODE ;OUTPUT ERROR STATUS
TXNE AC2,IO.IMP
OUTSTR [ASCIZ/ improper mode/]
TXNE AC2,IO.DER
OUTSTR [ASCIZ/ device error or insufficient system resources/] ;[1175]
TXNE AC2,IO.DTE
OUTSTR [ASCIZ/ data error/]
TXNN AC2,IO.BKT
POPJ PP,
TXNE AC13,DV.DSK ;DSK?
IFN TOPS20,<
OUTSTR [ASCIZ / quota exceeded or file structure full/]
>
IFE TOPS20,<
OUTSTR [ASCIZ / quota exceeded, file structure or rib full/]
TXNE AC13,DV.DTA ;DTA?
OUTSTR [ASCIZ / block number too large or DEC-TAPE is full/]
>
TXNN AC13,DV.DSK!DV.DTA ;ONLY ONE MESSAGE
OUTSTR [ASCIZ/ block too large/]
POPJ PP,
;OUTPUT CONTENTS OF AC2 BITS 18-35 (ERROR STATUS)
ERCODE: MOVEI C,"(" ;
OUTCHR C ;OUTPUT (
MOVEI AC1,6 ;SIX OCTAL NUMBERS
MOVE AC0,[POINT 3,2,17]
ERCOD1: ILDB C,AC0 ;GET NUMBER
ADDI C,"0" ;ASCIZE IT
OUTCHR C ;OUTPUT IT
SOJG AC1,ERCOD1 ;LOOP
MOVEI C,")" ;
OUTCHR C ;OUTPUT )
POPJ PP,
; EXTENDED ERROR CODE/TEXT
LTCTBL: [ASCIZ /Devop. failed while getting error code!/]
[ASCIZ /The page limit was exceeded./]
[ASCIZ /VFU format error./]
[ASCIZ /Label type error./]
[ASCIZ /Header label error./]
[ASCIZ /Trailer label error./]
[ASCIZ /Volume label error./]
[ASCIZ /Hard device error./]
[ASCIZ /Parity error./]
[ASCIZ /Write locked./]
[ASCIZ /Illegal positioning attempt./]
[ASCIZ /Code 13/]
[ASCIZ /Code 14/]
LTCLEN==.-LTCTBL
SUBTTL READ INTO THE BUFFER
;ALL BUFFERED INPUTS ARE DONE HERE. ***POPJ***
READIN: AOS D.IE(I16) ;BUMP INPUT COUNT
XCT UIN. ;***********************
POPJ PP, ;NORMAL RETURN
;SKIP RETURN IF OPEN/CLOSE/READ EOF
READCK: XCT UGETS. ; GET THE STATUS
MOVE AC13,D.DC(I16) ; AND DEVICE CHARACTERISTICS
TXNN AC13,DV.MTA ; MTA ?
JRST READC1 ; NO
TXNE AC2,IO.EOT ;SKIP IF NOT AN "EOT"
TXO AC16,FL%EOT ;"EOT" FLAG FOR READEF+N
READC1: TXNN AC2,IO.ERR!IO.EOF ;SKIP IF ANY ERRORS IN THE CURRENT BUFFER
JRST WRTXIT ;CLEAR THE ERRORS AND POPJ
MOVX AC0,E.MINP ;INPUT ERROR
TXNN AC2,IO.EOF ;SKIP IF AN EOF
JRST REAERR ;REAL ERRORS!
TXNN AC16,V%OPEN!CLS%EF!CLS%EV!CLS%BV ;SKIP IF OPEN OR CLOSE
JRST WRTRSX ;JUMP, IT'S READ OR WRITE "EOF"
JRST WRTRS1 ;EXIT BUT DONT SET ATEND
REAERR: PUSHJ PP,IGMDR ;IGNORE ERROR?
JRST WRTXIT ;YES
MOVE AC2,[BYTE (5) 35,31,20,10,4,14]
PUSHJ PP,MSOUT.
PUSHJ PP,IOERMS ;THE ERROR
JRST KILL ;
;READ IN SYNCHRONOUS MODE
READSY:
IFE TOPS20,<
PUSHJ PP,CLSYNC ;SINGLE BUFFERS
PUSHJ PP,READIN ;GET A BUFFER
JRST .+2 ;NORMAL RET
AOS (PP) ;EOF RETURN
JRST CLSYNC ;BACK TO MULTI BUFFERS
>;END IFE TOPS20
IFN TOPS20,<
PUSHJ PP,READIN ;GET A BUFFER
POPJ PP, ;RETURN NORMALLY
JRST RET.2 ;EOF RETURN
>;END IFN TOPS20
;HERE FOR NATIVE MODE I/O
IFN TOPS20,<
RDNIO: HRRZ AC2,D.IBH(I16) ; START OF BUFFER
HLL AC2,D.IBB(I16) ; BYTE SIZE
TLZ AC2,770000 ; CLEAR JUNK
TLO AC2,440000 ; POINT TO START
MOVEM AC2,D.IBB(I16) ; RESET IT
HRRZ AC1,D.FBS(I16) ; GET BUFFER SIZE
MOVE AC3,D.IBC(I16) ; GET COUNT OF WHATS LEFT
SUB AC3,AC1 ; NEGATIVE NO. OF BYTES
MOVEM AC1,D.IBC(I16) ; RESET COUNT
HRRZ AC1,D.JFN(I16) ; GET JFN
SIN%
ERJMP .+2
POPJ PP,
HALT
>
SUBTTL ERROR MESSAGES 5-JAN-70
;MOVE AC2,[BYTE (5),1,2,3,4] ;CALLING
;JRST MSOUT. ;SEQUENCE
MSOUT.: PUSH PP,AC2 ;INCASE DISPLAY DESTROYS IT
PUSHJ PP,DSPL1. ;OUTPUT BUFFER AND "CRLF"
POP PP,AC2
MSOUT1: MOVE AC0,[POINT 5,AC2] ;[563] POINT AT INDEX FROM AC0
ILDB AC1,AC0 ;PLACE IT IN AC1
XCT MSAGE(AC1) ;EXECUTE THE TABLE ITEM
JRST .-2 ;GO AGAIN
;MSDEV OUTPUTS THE SIXBIT DEVICE NAME
MSDEV.: SKIPN INRST. ;[530] SKIP IF NOT RESET UUO
SKIPA AC1,AC13 ;ELSE MAKE SURE U GET THE RIGHT DEV
HRRZ AC1,D.ICD(I16) ;GET THE CURRENT DEVICE
MOVE AC6,(AC1) ; [407] GET DEVICE NAME
DEVNAM AC6, ; [407] GET PHYSICAL NAME
JRST MSDEVA ; [407] NO SUCH DEVICE- DO REGULAR PRINTOUT
CAMN AC6,(AC1) ; [407] IS PHYSICAL = LOGICAL?
JRST MSDEVA ; [407] YES- NO REASON TO SAY IT TWICE
MOVE AC4,(AC1) ; [407] DEVICE NAME
DEVTYP AC4, ; [407] GET DEVICE TYPE
JRST MSDEVA ; [407] CANT
TXNE AC4,TY.SPL ; [407] IF SPOOLED FORGET IT
JRST MSDEVA
OUTSTR [ASCIZ / Logical device /] ;[536] [407]
PUSHJ PP,MSDVA0 ;[536] TYPE LOGICAL DEVICE
OUTSTR [ASCIZ/; physical device /] ; [407]
MOVE AC3,AC6 ; [407] PHYSICAL DEVICE
PUSHJ PP,MSDEV1 ;[536] [407] TYPE AND RETURN
JRST COLON ;[536] PRINT ":"
MSDEVA: OUTSTR [ASCIZ/ Device /]
MSDVA0: MOVE AC3,(AC1) ;DEVICE NAME
PUSHJ PP,MSDEV1 ;[536] PRINT IT
COLON: MOVEI C,":" ;[536] GET COLON
OUTCHR C ;[536] PUT IT OUT AT END
POPJ PP, ;[536] AND RETURN
MSDEV1: MOVEI AC4,6 ;6 CHARS
SKIPA AC1,[POINT 6,AC3] ;POINT AT IT
MSFIL1: PUSHJ PP,OUT6B. ;ASCIZE IT AND PLACE IN BUFFER
MSFIL2: ILDB C,AC1 ;PICKUP THE NEXT CHAR
CAIE C,0 ;TERMINATE ON A SPACE
SOJGE AC4,MSFIL1 ; OR SATISFIED CHAR COUNT
JRST OUTBF. ;EXIT
;MSFIL OUTPUTS THE SIXBIT FILE NAME
MSFIL.: MOVEI AC4,^D30 ;30 CHARS
OUTSTR [ASCIZ / File /]
MOVE AC1,[POINT 6,(I16)] ;POINT AT A FILE NAME
PUSHJ PP,MSFIL2 ;OUTPUT FILE NAME
;OUTPUT THE VALUE-OF-ID AS [ FILE EXT ]
MSVID: TLNE FLG,IDXFIL ;[323] IS THIS AN ISAM FILE?
SKIPE FS.IF ;[323] YES,IS ERROR IN DATA FILE?
JRST MSVID2 ;[323] "NO" TO EITHER QUESTION
MOVE AC1,[POINT 6,DFILNM(I12)] ;[323] WANT DATA FILENAME
TLNE I16,-1 ;[323] UNLESS IN RESET
JRST MSVID3 ;[323] CONTINUE
MSVID2: SKIPN AC1,F.WVID(I16) ;[323] BP TO VALUE OF ID
POPJ PP, ;EXIT IF NO ID
MSVID3: LDB AC4,F.BSID ;GET SIZE OF VALUE-OF-ID
SKIPN AC4
MOVEI AC4,^D9 ;9 CHARACTERS BY DEFAULT
MSVID4: OUTSTR [ASCIZ/ [/] ;[323]
MSVID1: ILDB C,AC1
TLNN AC1,100 ;[304] SKIP IF ASCII
ADDI C,40 ;[304] CONVERT SIXBIT TO ASCII
TLNN AC1,600 ; EBCDIC?
LDB AC1,IPT971## ; [616] YES
PUSHJ PP,OUTCH. ;[304] OUTPUT TO BUFFER
SOJG AC4,MSVID1 ;LOOP
PUSHJ PP,OUTBF. ;DUMP THE BUFFER
JRST MSPPNE ;"]" AND EXIT
;OUTPUT THE SIXBIT REEL NUMBER
MSDTRN: LDB AC3,DTRN. ;FROM THE DEVICE TABLE
JRST MSSLR1 ;
MSSLRN: HRL AC3,STDLB.+4 ;THE
HLR AC3,STDLB.+5 ; STANDARD
ROT AC3,-14 ; LABEL
ANDI AC3,7777 ; REEL NUMBER
MSSLR1: OUTSTR [ASCIZ/ reel /]
ROT AC3,-14
JRST MSDEV1
;[277] ROUTINE TO PRECEDE MESSAGES TO TTY WITH "$"
$SIGN: OUTSTR [ASCIZ/
$ /] ;[277]
POPJ PP, ;[277]
;[536] TYPE OUT A DIRECTORY
MSDIR.: OUTSTR [ASCIZ /[/] ;[536]
IFE TOPS20,<
TLNE AC3,-1 ;[536] CHECK FOR SFD PATH
JRST MSPPN. ;[536] NO
ADDI AC3,2 ;[536] POINT TO PPN
HLRZ AC0,(AC3) ;[536] LHS
PUSHJ PP,PUTOCT ;[536] TYPE OCTAL
OUTSTR [ASCIZ /,/] ;[536]
HRRZ AC0,(AC3) ;[536] RHS
PUSHJ PP,PUTOCT ;[536] TYPE OCTAL
AOS AC6,AC3 ;[536] ADVANCE TO SFD
HRLI AC6,-5 ;[536] MAX LENGTH OF SFDS
MSSFD: SKIPN AC3,(AC6) ;[536] GET NEXT
JRST MSPPNE ;[536] AT END
OUTSTR [ASCIZ /,/] ;[536]
PUSHJ PP,MSDEV1 ;[536] OUTPUT IT
AOBJN AC6,MSSFD ;[536] LOOP
JRST MSPPNE ;[536] JUST IN CASE
>
MSPPN.: JUMPL AC3,[PUSHJ PP,MSDEV1 ;[536] TYPE AS SIXBIT
JRST MSPPNE] ;[536]
HLRZ AC0,AC3 ;[536] LHS
PUSHJ PP,PUTOCT ;[536] TYPE OCTAL
OUTSTR [ASCIZ /,/] ;[536]
HRRZ AC0,AC3 ;[536] RHS
PUSHJ PP,PUTOCT ;[536] TYPE OCTAL
MSPPNE: OUTSTR [ASCIZ /]/] ;[536] CLOSE PPN
POPJ PP, ;[536] AND RETURN
;TYPE OUT A SIGNED DECIMAL NUMBER, REMOVING LEADING ZEROES [371]
PUTDEC: JUMPGE AC0,PUTDC1 ;IF NEGATIVE, [371]
OUTSTR [ASCIZ "-"] ; TYPE SIGNED AND [371]
MOVMS AC0 ; GET MAGNITUDE [371]
PUTDC1: IDIVI AC0,^D10 ; DIVIDE BY RADIX TO [371]
HRLM AC1,(PP) ; SAVE RADIX DIGIT [371]
SKIPE AC0 ; DONE ? [371]
PUSHJ PP,PUTDC1 ; NO-- LOOP [371]
HLRZ C,(PP) ; GET SAVED DIGIT [371]
ADDI C,"0" ; CONVERT TO ASCII [371]
OUTCHR C ; TYPE DIGIT [371]
POPJ PP, ; [371]
; [536] TYPE OUT AN OCTAL NUMBER
PUTOCT: IDIVI AC0,8 ;[536] DIVIDE BY RADIX
HRLM AC1,(PP) ;[536] SAVE RADIX DIGIT
SKIPE AC0 ;[536] DONE ?
PUSHJ PP,PUTOCT ;[536] NO-- LOOP
HLRZ C,(PP) ;[536] GET SAVED DIGIT
ADDI C,"0" ;[536] CONVERT TO ASCII
OUTCHR C ;[536] TYPE DIGIT
POPJ PP, ;[536] AND RETURN
;THE FOLLOWING 40 LOC TABLE IS "XCT"ED FROM MSOUT.
;****** DO NOT ADD ANY MORE MESSAGES *****
MSAGE: JRST KILL ;0
OUTSTR [ASCIZ/
shares buffer area with /] ;1
OUTSTR [ASCIZ/ cannot be opened/] ;2
OUTSTR [ASCIZ/, already open/] ;3
OUTSTR [ASCIZ/
/] ;4
OUTSTR [ASCIZ/ Too many open files/] ;5
OUTSTR [ASCIZ/ is not open/] ;6
OUTSTR [ASCIZ/ for INPUT./] ;7
PUSHJ PP,MSFIL. ;10 - 30 CHARACTER FILENAME
OUTSTR [ASCIZ/ for OUTPUT only./] ;11 [1037]
OUTSTR [ASCIZ/ is AT END./] ;12
OUTSTR [ASCIZ/ is not a device./] ;13
POPJ PP, ;14 - RETURN
OUTSTR [ASCIZ/ is not available to this job./] ;15
OUTSTR [ASCIZ/ is assigned to another file./] ;16
OUTSTR [ASCIZ . cannot do INPUT/OUTPUT.] ;17
PUSHJ PP,MSDEV. ;20 - 6 CHARACTER DEVICE NAME
OUTSTR [ASCIZ/ cannot do INPUT./] ;21
OUTSTR [ASCIZ/ cannot do OUTPUT./] ;22
OUTSTR [ASCIZ/ or /] ;23
PUSHJ PP,C.STOP ;24
OUTSTR [ASCIZ/Init took the error return./] ;25
OUTSTR [ASCIZ/Directory devices must have standard labels./] ;26
OUTSTR [ASCIZ/ to/] ;27
PUSHJ PP,MSDTRN ;30 - DEVICE TABLE REEL NUMBER
OUTSTR [ASCIZ/ on/] ;31
IFE TOPS20,<
OUTSTR [ASCIZ/Labels may not be omitted from DTA or DSK files./] ;32
>
IFN TOPS20,<
OUTSTR [ASCIZ/Labels may not be omitted from DSK files./] ;32
>
OUTSTR [ASCIZ/ because it is not open./] ;33
PUSHJ PP,MSSLRN ;34 - STANDARD LABEL REEL NUMBER
OUTSTR [ASCIZ/ INPUT error/] ;35
OUTSTR [ASCIZ/ OUTPUT error/] ;36
OUTSTR [ASCIZ/ cannot be closed./] ;37
;****** DO NOT ADD ANY MORE MESSAGES *****
;LOOKUP OR ENTER ERROR MESSAGES. ***KILL OR OPNENR***
LUPERR: MOVE AC0,ULBLK.+1 ;[1010] MOVE LOOKUP ERROR
MOVEM AC0,UEBLK.+1 ;[1010] TO ENTER BLOCK
TDZA ;LOOKUP ERROR
ENRERR: SETO ;ENTER ERROR
PUSHJ PP,SAVAC.
LDB AC1,F.BOUP ;GET THE OEUP FLAG
HRRZ AC2,UEBLK.+1 ;GET THE ERROR CODE
TRZ AC2,777740 ; CLEAR THE REST
CAIN AC2,3 ;IF ERROR IS FILE BEING MODIFIED
JUMPN AC1,ENRAGN ;YES, IF FLAG ON SEE IF USE PRO
ENRER2: TXNN AC16,V%OPEN ;OPEN OR CLOSE UUO
SKIPA AC2,[BYTE (5)10,37,31,20,4,14] ;CLOSE!
MOVE AC2,[BYTE (5)10,2,31,20,4,14]
MOVE AC13,D.ICD(I16) ;[277] DEVICE NAME
DEVCHR AC13, ;[277] DEVCHR UUO
TXNE AC13,DV.DTA!DV.MTA ;[277] A REEL DEVICE?
PUSHJ PP,$SIGN ;[277] YES, OUTPUT "$"
PUSHJ PP,MSOUT. ;<FILE> CANNOT BE OPENED ON <DEVICE>
MOVEI AC2,[ASCIZ/
LOOKUP /]
SKIPE (PP) ;SKIP IF LOOKUP UUO
MOVEI AC2,[ASCIZ/
ENTER /]
SKIPE PRGFLG ;RENAME FAILURE?
MOVEI AC2,[ASCIZ /
RENAME /]
TLNE FLG1,FOPERR ;FILOP FAILURE?
MOVEI AC2,[ASCIZ/
FILOP. /]
OUTSTR (AC2) ; LOOKUP, ENTER, RENAME OR FILOP
OUTSTR [ASCIZ /failed, /]
HRRZ AC2,ULBLK.+1
SKIPE (PP) ;SKIP IF LOOKUP UUO
HRRZ AC2,UEBLK.+1
TRZ AC2,777740 ;SAVE ONLY THE ERROR BITS
PUSHJ PP,ERCODE ;OUTPUT THE ERROR CODE
CAIL AC2,LEMLEN ;A LEGAL ERROR CODE?
HRRI AC2,LEMLEN ;NO, GIVE CATCH-ALL
JUMPN AC2,ENRER1 ;
SKIPE (PP) ;SKIP IF LOOPUP
HRRI AC2,LEMLEN+1 ;ILL-FIL-NAME NOT FIL-NOT-FND
ENRER1: OUTSTR @LEMESS(AC2) ;TYPE A MESSAGE
SKIPN (PP) ;KILL IF ENTER
TXNN AC13,DV.DTA!DV.MTA ;A REEL DEVICE?
JRST KILL ;NO
JUMPN AC2,KILL ;KILL IF NOT UNFOUND FILE
OUTSTR [ASCIZ/ Wrong reel? /]
PUSHJ PP,C.STOP ;WAIT FOR CONTINUE
PUSHJ PP,RSTAC. ;RESTORE THE ACS
TLNN AC16,-1 ;SKIP IF NOT CALLED W/ A PUSHJ
POPJ PP, ;EXIT TO RRDMP
JUMPE AC0,OPNLUP ;TRY
JRST OPNENR ;AGAIN.
;PERFORM USE PROCEDURE AND RETRY ENTER UUO
;LOOP TILL ENTER WINS OR USER GIVES UP IN USE-PRO.
ENRAGN: MOVEI AC1,0 ;PERFORM ERROR USE PRO
SKIPN FS.UPD ;SKIP IF ALREADY DONE
PUSHJ PP,USEPRO ; ERROR USE PRO
JRST .+2 ;NORMAL RETURN
JRST ENRER2 ;NO USE PRO - GIVE ERROR MESS. AND KILL
SETZM FS.UPD ;CLEAR THE USE-PRO-DONE FLAG
PUSHJ PP,RSTAC. ;RESTORE ACS
TLNE FLG1,EIX ;IF INDEX FOR ISAM FILE
JRST OPNI00 ; EXIT HERE
LDB AC5,DTCN. ;[1152] CORRECT VALUE IN AC5 FOR RETRY
JRST OPNCH1 ;[1113] TRY AGAIN
;LOOKUP/ENTER ERROR MESSAGES
LEMESS: [ASCIZ \ file not found.\]
[ASCIZ \ UFD does not exist.\]
IFE TOPS20,<
[ASCIZ \ protection failure.\]
>
IFN TOPS20,<
[ASCIZ \ Protection failure or DTA directory full.\]
>
[ASCIZ \ File being modified.\]
[ASCIZ \ RENAME file already exists.\]
[ASCIZ \ Illegal sequence of UUOs.\]
[ASCIZ \ Device or UFD/RIB data error.\]
[ASCIZ \ Not a SAVed file.\]
[ASCIZ \ Not enough core.\]
[ASCIZ \ Device not available.\]
[ASCIZ \ No such device.\]
[ASCIZ \ FILOP. illegal monitor call.\]
[ASCIZ \ Quota exceeded or no room on file structure.\]
[ASCIZ \ WRITE locked file structure.\]
[ASCIZ \ Not enough monitor table space.\]
[ASCIZ \ Partial allocation only.\]
[ASCIZ \ Allocated block not free.\]
[ASCIZ \ Can't supersede (ENTER) an existing directory.\]
[ASCIZ \ can't delete (RENAME) a non-empty directory.\]
[ASCIZ \ SFD not found.\]
[ASCIZ \ SEARCH list empty.\]
[ASCIZ \ SFD nested too deeply.\]
[ASCIZ \ No-create on for specified SFD path.\]
[ASCIZ \ Segment not on swap space.\]
[ASCIZ \ Can't update file.\]
[ASCIZ \ LOW segment overlaps HIGH segment.\]
[ASCIZ \ User not logged in.\]
[ASCIZ \ File has outstanding locks set.\]
[ASCIZ \ Bad EXE directory.\]
[ASCIZ \ Bad EXE extension.\]
[ASCIZ \ EXE directory too big.\]
[ASCIZ \ Network capacity exceeded.\]
[ASCIZ \ Task not available.\]
[ASCIZ \ Unknown network node specified.\]
[ASCIZ \ Rename-SFD is in use.\]
[ASCIZ \ Delete-file has an NDR block.\]
[ASCIZ \ Job count too high.\]
LELAST: [ASCIZ \ LOOKUP, ENTER or RENAME error\]
LEMLEN==LELAST-LEMESS
[ASCIZ \ illegal filename.\]
SUBTTL CLOSE VERB
;A C.CLOS VERB LOOKS LIKE:
;FLAGS,,ADR WHERE ADR = FILE TABLE ADDRESS
;BIT9 =0 CLOSE FILE
;BIT9 =1 CLOSE REEL
;BIT10 =1 LOCK, LOCKED FILES MAY NOT BE REOPENED
;BIT11 =1 DON'T REWIND
;BIT12 =1 ALWAYS 1 (VS. 0 = OPEN)
;BIT13 =1 UNLOAD
;CALL+1: POPJ RETURN
;EXIT IF OPTIONAL FILE IS NOT PRESENT, ERROR MESSAGE IF IT'S NOT
;OPEN OR IF IT'S A "CLOSE REEL" AND A MULTI-FILE REEL.
;WRITE OUT ANY ACTIVE DATA REMAINING IN THE BUFFER FROM RANDOM
;OR IO FILES.
PURGE.: TLZ AC16,(Z 17,)
TXO AC16,V%CLOS ;MAKE PURGE BE A CLOSE VERB
SETOM PRGFLG ;REMEMBER TO RENAME TO ZERO
C.CLOS: MOVE AC0,[FS.ZRO,,FS.FS];ZERO THE ERROR
BLT AC0,FS.IF ; STATUS WORDS.
SETOM FS.IF ;IDX FILE
MOVE FLG,F.WFLG(I16) ;PICK UP THE FLAGS
HLLZ FLG1,D.F1(I16) ;MORE FLAGS
SKIPGE WANT8. ;WANT 8x FUNCT?
TLNE FLG,OPNIO ;IS THIS FILE OPEN AT ALL?
JRST CLOS02 ;WANT 74 OR FILE OPEN (OR BOTH)
MOVEI AC0,FS%42 ;CLOSING WITHOUT FILE OPEN
MOVEM AC0,FS.FS ;SAVE FOR REPORTING
MOVX AC0,E.VCLO ;TELL ERROR RECOVERY THAT WE ARE CLOSING
PUSHJ PP,IGCVR ;
SKIPA ;IGNORE ERROR
PUSHJ PP,KILL ;FATAL
CLOS02: TLNN FLG,NOTPRS ;SKIP IF FILE IS NOT PRESENT
JRST CLOS01 ; BUT IT IS
SETZM PRGFLG ;INCASE IT WAS CLOSE WITH DELETE
TLZ FLG,OPNIN!OPNOUT!ATEND!NOTPRS!CONNEC
MOVEM FLG,F.WFLG(I16) ;REINIT THE FLGS
POPJ PP, ;EXIT
CLOS01: TLNE FLG,OPNIN+OPNOUT ;FILE NOT OPEN?
JRST CLOS05 ;FILE IS OPEN
SKIPN F.WSMU(I16) ;IF SMU OPTION 1 BEING DONE, OPEN MUST
; HAVE FAILED, SO WE ARE JUST CLEANING UP
; NO NEED TO
JRST PRGERR ;[1003] BOMB THE USER OUT
POPJ PP, ; JUST RETURN TO CALLING ROUTINE
CLOS05: ;
MOVE AC13,D.DC(I16) ;PICK UP DEVICE CHARACTERISTICS
TXNN AC16,CLS%CR!CLS%NR!CLS%UN ;TRYING TO CLOSE REEL, NO REWIND, REEL
JRST CLOS04 ; NO
TXNE AC13,DV.MTA ;MAG-TAPE DEVICE?
JRST CLOS04 ;YES
SKIPL WANT8. ;8-X?
JRST CLOS04 ;NO
MOVEI AC0,FS%07 ;YES,IS "FRIENDLY" ERROR
MOVEM AC0,FS.FS ;SAVE FOR REPORTING
HRRZI AC0,0 ;CLEAR AC0 FOR ERROR RECOVERY ADD PROC
TXO AC16,CLS%IC ;FLAG AC16 FOR INVALID CLAUSE ON CLOSE
PUSHJ PP,IGCVR ;
TRN ;IGNORE ERROR RETURN
CLOS04:
IFN TOPS20,<
TXNE AC13,DV.LPT ;SIMPLE OUTPUT DEVICE
JRST CLSLPT ;YES, USE NATIVE CODE
>
TXNN AC13,DV.DIR ;A DIRECTORY DEVICE?
SETZM PRGFLG ;NO - SO WE CAN'T PURGE
TXNE AC13,DV.TTY ;A TTY FILE?
SETZM TTYOPN ;YES, NOTE THAT IT'S CLOSED
TXNN AC16,CLS%CR ;SKIP IF CLOSE REEL
JRST CLOSE0
TXNN AC13,DV.MTA ;MTA?
POPJ PP, ; NO, IGNORE & CONTINUE
TXO AC16,CLS%EV ;% CLOSE REEL
LDB AC5,F.BPMT ;FILE POSITION ON TAPE
JUMPN AC5,CLOSF5 ;CLOSE "REEL" A MULTI-FILE-REEL - AN ERROR
JRST CLOS00
CLOSE0: TXO AC16,CLS%EF ;%CLOSE FILE
CLOS00: PUSHJ PP,SETCN. ;DISTRIBUTE THE CHAN NUMBER
HLRZ AC12,D.BL(I16) ;BUFFER LOCATION
TLNE FLG,IDXFIL ;INDEXED FILE?
JRST CLSISM ;YES
TLNN FLG,RANFIL+IOFIL ;[622] SKIP IF RANDOM OR IO
JRST CLOSE1 ; NO LONGER PAD LOGICAL BLOCKS
TLNE FLG,RANFIL ;[657] SKIP IF IO-FILE
JRST CLOS03 ;
TLC FLG,OPNIN!OPNOUT!ATEND ;
TLCE FLG,OPNIN!OPNOUT!ATEND ;SKIP IF IO-FILE AND ATEND
TLNN FLG,OPNIN ;SKIP IF OPEN FOR INPUT
PUSHJ PP,CLSZBF ;IO-FILE AND ATEND OR OUTPUT FILE
CLOS03: SKIPE R.DATA(I12) ;SKIP IF NO ACTIVE DATA IN BUFFER
PUSHJ PP,RANOUT ;WRITE IT OUT
HLLZS UOUT. ;CLEAR IOWD POINTER
JRST CLOSE3 ;
;PAD THE LAST LOGICAL BLOCK IF NECESSARY.
; THE PADDING AT THE END OF THE LOGICAL BLOCK HAS BEEN ELIMINATED
; SO THAT OPEN APPEND WILL WORK CORRECTLY FOR BLOCKED DISK
CLOSE1:
; BL/10/27/80 TLNE FLG,OPNOUT ; SKIP IF NOT AN OUTPUT FILE
TLNN FLG,OPNOUT ;SKIP IF OUTPUT FILE
JRST CLOSE3 ; DON'T PAD
; TXNE AC13,DV.MTA ;[1014] MTA? allow mta to have extra 'CR'
; JRST CLOSE2 ;[1014] YES, SKIP FUNNY EXTRA 'CR'
HRRZ AC4,D.RFLG(I16) ; NO, GET STD ASCII FLAG
TRNE AC4,SASCII ;[1112] IS IT?
JRST CLOSE2 ;[1112] YES, THEN NO <CR>
TRZE AC4,AFTADV ;[1112] SKIP IF DON'T NEED 'CR'
;If you don't want the extra <cr> at the end of the file
;replace the instruction at NOXCR. by a JFCL
;However that is contrary to the ANSI-74 standard as interpreted by the FCTC.
NOXCR.::PUSHJ PP,WRTCR ; WRITE 'CR'
HRRM AC4,D.RFLG(I16) ; RESET FLAG
CLOSE2: SKIPGE D.OBB(I16) ; SKIP IF BUFFER MIGHT HAVE DATA(NOT 44S00,LOC)
JRST CLOSE3 ; NO LONGER PAD LOGICAL BLOCKS
HRRZ AC1,D.OBH(I16) ; GET BUF HDR ADDR
HRRZ AC3,D.OBB(I16) ; GET BYTE PTR LOC ADDR
CAIE AC1,-1(AC3) ; SKIP IF AT BEGIN OF BUFFER
PUSHJ PP,WRTBUF ; WRITE OUT LAST BUFFER
;READ A LABEL AND CHECK FOR "EOF/V" LABEL TYPE.
CLOSE3: TXNN AC13,DV.MTA ; IS A MTA?
JRST CLOSE7 ; NO, SO SKIP ALL LABEL STUFF
TLNN FLG,OPNOUT!ATEND
JRST CLOSE8 ;SKIP LABEL PROCESSING, READ AND NOT ATEND
TLNE FLG,OPNIN ;IF INPUT,
JRST CLOSE4 ; NO,
HRRZ AC0,D.RFLG(I16) ; GET SOME FLAGS
TRNE AC0,RDDREV ; READ REVERSE OPEN ACTIVE?
JRST CLOSE4 ; YES,SKIP LABEL READ
PUSHJ PP,CLSRL ; NO, READ A LABEL
LDB AC5,F.BPMT ;[341] SEE IF FILE POSITIONED
JUMPN AC5,CLOSE4 ;[341] IF THERE IS, SKIP NEXT
TLNN FLG,OPNIN ;[341] OPEN FOR INPUT?
JRST CLOSE6 ;[341] NO
TXNE FLG1,B%STL ;[341] IF LABELLED
XCT MADVF. ;[341] SKIP OVER EOF AFTER LABEL REC.
CLOSE4: TLNN FLG,OPNIN ;SKIP IF INPUT
JRST CLOSE6 ;JUMP IF OUTPUT
TXNE FLG1,B%STL ;SKIP IF NOT STD LABELS
TXNN AC16,CLS%EV ;SKIP IF CLOSE REEL
JRST CLOSE7 ;
PUSHJ PP,CLSEOV ;CHECK FOR EOV
JRST CLOSE7 ;
OUTSTR [ASCIZ /Standard END-OF-REEL labels must have "EOV" as the first three characters./]
MOVE AC2,[BYTE (5)10,31,20,37]
JRST MSOUT. ;TYPE IT OUT
;CREATE A LABEL, WRITE OUT THE LABEL AND LOCK THE FILE.
CLOSE6: PUSHJ PP,CLSCAL ;CREATE STD MTA ENDING LABEL
CLOSE7: TLNE FLG,OPNOUT ;SKIP IF NOT OUTPUT
PUSHJ PP,CLSWEL ;WRITE ENDING LABEL MAYBE
CLOSE8: HRRZ AC1,D.RFLG(I16) ; GET SOME FLAGS
TRZE AC1,RDDREV ; READ REVERSE OPEN ACTIVE?
HRRM AC1,D.RFLG(I16) ; IF SO PUT IT BACK AFTER CLEARING IT
TXNE AC16,CLS%CR ;SKIP IF CLOSE FILE
JRST CLOSR1 ;CLOSE REEL
TXNN AC16,CLS%LK ;LOCK THE FILE?
JRST CLOSF1 ;NO
SETO AC0, ;SET THE LOCK FLAG
DPB AC0,F.BLF ;SAVE IT
XCT MREWU. ;REWIND AND UNLOAD**************
JRST CLOSF2
;REWIND OR POSITION THE MTA, RESET THE FLAGS, RELEASE THE
;DEVICE AND EXIT. ***POPJ***ACP***
CLOSF1: TXNE AC16,CLS%NR ;REWIND REQUEST?
JRST CLOSF3 ;NO
IFN TOPS20,< ;YES
TLNN FLG1,MTNOLB ;SKIP IF MOUNTR WITH NO LABELING
JRST CLSF1X ;ELSE GO ON
SETZ AC4, ;INDICATE GET FIRST REEL
PUSHJ PP,VOLSWT ;GET FIRST REEL IF MOUNTR AND NO LABELING
;NOW WE WILL ALSO REWIND TO MAKE SURE
;WE ARE AT BOT IF NO REEL SWITCH HAPPENED
CLSF1X: >;END IFN TOPS20
TXNN AC13,DV.MTA ;MTA?
JRST CLOSF2 ;NO, SKIP TAPE STUFF
PUSHJ PP,OPNRWD ;REWIND UUO
TXNE AC16,CLS%UN ;UNLOAD?
XCT MREWU. ;YES
CLOSF2: MOVX AC0,B%HUF
ANDCAM AC0,D.HF(I16) ;CLEAR HUF FLAG
JRST CLOSF4 ;
CLOSF3: LDB AC5,F.BPMT ;GET FILE POSITION
JUMPE AC5,CLOSF4 ;DONT POSITION IF NONE IS SPECIFIED
TLNN FLG,OPNOUT ;OPEN FOR OUTPUT?
JRST CLOSF9 ;NO
TXNE FLG1,B%STL ;LABELED FILE?
XCT MBSPF. ;YES, BACK INTO THE LABEL
CLOSF9: TLNE FLG,OPNOUT!ATEND ;SKIP IF INPUT AND NOT "AT-END"
XCT MBSPF. ;BACK SPACE INTO THE FILE
IFN TOPS20,<
TLNN FLG1,MSTNDR ;SKIP IF MOUNTR DOING LABELING
>
TLNE FLG,OPNOUT!ATEND;[336] IF OUTPUT OR AT END
JRST CLOSF4 ;[336] WE ARE DONE
SKIPL D.IBH(I16) ;[336] IF HAVE DONE ANY READS
XCT MBSPR. ;[336] BACKSPACE 1 RECORD
CLOSF4: TLNN FLG,IDXFIL ;[336] INDEX FILE?
JRST CLOSF7 ;NO
PUSHJ PP,CLSIDX ;YES, CLOSE & RELEAS THE INDEX-FILE
PUSHJ PP,FRECH1 ;MAKE CHAN AVAILABLE
MOVE AC1,CORE0(I12) ;UNTIL,,FROM
SETZM (AC1) ;ZERO FIRST WORD
HLRZ AC2,AC1 ;UNTIL
HRL AC1,AC1 ;FROM,,FROM
ADDI AC1,1 ;FROM,,TO
BLT AC1,(AC2) ;ZERO
CLOSF7: SKIPN PRGFLG ;PURGE?
JRST CLOSF8 ;NO
TLNN FLG,OPNIN!RANFIL!IDXFIL ;SUPERSEDING?
JRST CLOS75 ;COULD BE - GO SEE
CLOS71: PUSHJ PP,OPNEID ;
SETZM UEBLK. ;ZERO THE FILE-NAME
XCT URNAM. ;DELETE IT *******************
PUSHJ PP,ORERRI ;ERROR RET
CLOS72: SETZM PRGFLG ;CLEAR THE FLG
CLOSF8:
IFN TOPS20,< ;IF MOUNTR WITH LABELS WE ARE
;AT THE BEG OF THE NEXT FILE
;,NOT IN THE CURRENT ONE
;(BECAUSE THE MONITOR POSITIONS
;TO THE BEGINING OF THE NEXT FILE
;AFTER THE JFN IS CLOSED)
TLNE FLG1,MSTNDR ;IS MOUNTR DOING LABELING AND
TLNE FLG,OPNOUT!ATEND ;OPEN INPUT AND NOT ATEND ?
JRST CLSF8X ;NO,GO RELEASE
MOVX AC5,B%HUF ;YES, GET HEAD UNDER FLAG BIT
TDNN AC5,D.HF(I16) ;SKIP IF HEAD HERE
JRST CLSF8X ;IF NOT GO ON
ANDCAM AC5,D.HF(I16) ;CLEAR CURRENT HEAD POS
LDB AC1,F.BPMT ;GET CURRENT POSITION NUMBER
MOVE AC2,AC1 ;GET HERE
ADDI AC2,1 ;PLUS ONE FOR LOOP TEST
MOVE AC10,I16 ;START SEARCH FOR NEXT FILE HERE
CLSF8B: HRRZ AC10,F.RFSD(AC10) ;GET NEXT FILTAB ADDR
JUMPE AC10,CLSF8X ;[632] CONT IF NO FILTAB SHARES DEVICE
CAIN AC10,(I16) ;ARE WE BACK AT START?
JRST CLSF8X ;YES,NO NEXT FILE, SO GO ON WITH HUF FLG OFF
LDB AC3,FLPS10 ;GET FILE POSITION AT THIS FILE
CAIE AC3,(AC2) ;IS THIS THE NEXT FILE ON THE TAPE?
JRST CLSF8B ;NO, LOOP BACK
ORM AC5,D.HF(AC10) ;YES,SET HEAD UNDER THIS FILE
;NOW GO RELEASE
CLSF8X:
>;END IFN TOPS20
SETZM D.DC(I16) ;DEVICE CHARACTERISTICS
TLZ FLG,OPNIN+OPNOUT+ATEND+NOTPRS+CONNEC
MOVEM FLG,F.WFLG(I16) ;REINITIALIZE THE FLAGS
TLZ FLG1,F1CLR ; CLEAR SOME FLAGS
HLLM FLG1,D.F1(I16) ;REINIT MORE FLAGS
MOVX AC0,RF1CLR ; GET MORE FLAGS
ANDCAM AC0,D.RFLG(I16) ; TO CLEAR
IFN TOPS20,<
TXNE FLG1,B%NIO ;NATIVE I/O?
JRST [HRRZS AC1,D.JFN(I16) ;CLEAR JFN
RLJFN%
HALT
JRST .+2] ;OK
>
XCT URELE. ;RELEASE THE DEVICE**************
PUSHJ PP,CLRSTS ;CLEAR FILE STATUS WORD
JRST FRECHN ;EXIT TO THE COBOL PROGRAM
CLOSF5: MOVX AC0,E.FIDX+FE%21 ;ERROR NUMBER
TLNN FLG,IDXFIL ;SKIP IF AN ISAM FILE
MOVX AC0,FE%21 ;ERROR NUMBER
PUSHJ PP,IGCVR ;IGNORE ERROR?
JRST CLOS00 ;CONTINUE
MOVE AC2,[BYTE(5)10,31,20,37,14]
PUSHJ PP,MSOUT.
OUTSTR [ASCIZ/
The CLOSE "REEL" option may not be used with a multi-file-tape./]
JRST KILL
CLOS75: LDB AC1,DTCN. ;GET THE CHANNEL NUMBER
TXNE AC13,DV.DIR ;[373] DIRECTORY DEVICE ?
TXNE AC13,DV.DSK ;[373] DSK? IF NO IT IS DTA DO RENAME
RESDV. AC1, ;RESET THIS CHANNEL IE DELETE
JRST CLOS71 ;FAILED SO RENAME TO ZERO
JRST CLOS72 ;RETURN
;CLOSE REEL, REWIND AND UNLOAD, RELEASE THE DEVICE, GENERATE
;AN OPEN UUO AND GO DOIT. ***OPNDEV***
CLOSR1:
TXNN FLG,B%RER ;RERUN ON END OF REEL?
JRST CLOSR2 ;NO
SETZM D.OE(I16) ;CLEAR THE NUMBER OF INS + OUTS SO
SETZM D.IE(I16) ; RERUN DOESNT ROCK MAGTAPE
PUSHJ PP,RRDMP ;YES
PUSHJ PP,RSAREN ;RESTORE .JBSA, .JBREN
PUSHJ PP,SETCN. ;CHAN NUMBERS DISTURBED BY RRDMP CODE
XCT UCLOS. ;ELSE RELEASE TRYS TO DUMP "DUMMY BUFFER" CAUSED BY DUMMY OUT
; WHICH CAUSES REQUEST FOR OPR1 INTERVENTION!!?
CLOSR2: TXZE AC16,CLS%NR ; NO REWIND?
JRST CLSR2B ; YES, DON'T REWIND
IFN TOPS20,<
TLNN FLG1,MSTNDR ; SYS-LABELED?
JRST CLSR2C ; NO, UNLOAD
XCT MREW. ; YES JUST REWIND
JRST CLSR2B ; AND SKIP
>;END IFN TOPS20
CLSR2C: XCT MREWU. ;REWIND AND UNLOAD
CLSR2B: TLZ FLG,ATEND ; [604] TURN OFF THE EOF FLAG
MOVEM FLG,F.WFLG(I16) ; [604] ALSO IN THE FILE TABLE
PUSHJ PP,INCRN. ;INCREMENT THE DEVTAB REEL NUMBER
LDB AC0,F.BNDV ;GET NUMBER OF DEVICES SELECTED
SOJE AC0,CLSR2A ;JUMP IF ONLY ONE
MOVE AC0,D.ICD(I16) ;GET THE NEXT DEVICE
AOBJN AC0,.+2 ;JUMP IF THERE IS ONE
PUSHJ PP,DEVIOW ;RESET DEVICE IOWD
MOVEM AC0,D.ICD(I16) ;SAVE AS CURRENT IF THERE IS
JRST CLOSR4 ; GO ON
IFN TOPS20,<
;
; VOLSWT IS A ROUTINE TO SWITCH MTA REELS WHEN UNDER
; MOUNTR CONTROL,BUT WITH NO MONITOR LABELING.
;
; ARG: AC4= 0 IF MOUNT FIRST REEL
; .VSMRV IF MOUNT NEXT REEL
;
; USES: AC1,AC2,AC3,AC4,AC5
;
VOLSWT: HRRZ AC1,D.JFN(I16) ;GET JFN
;NOW MUST DO OPENF TO MAKE SURE THE JFN IS OPEN
MOVE AC3,AC1 ;SAVE JFN IN CASE OF OPENF ERROR
MOVE AC2,[440000,,OF%RD] ;INDICATE SIMPLE 36 BIT BYTE,INPUT
OPENF% ;OPEN THE JFN***************
ERCAL OPNFER ;ERROR?, THEN GO CHECK IT (RETURNS IF OK)
VOLSW1: MOVEI AC2,.MOVLS ;INDICATE VOLUME SWITCH MTOPR
JUMPE AC4,VOLSW2 ;JUMP IF GET FIRST REEL
MOVEI AC3,3 ;INDICATE THAT THERE ARE 3 ARGS,BEGINING
;AT LOCATION 3.
MOVEI AC5,1 ;INDICATE GET RELATIVE REEL 1 (NEXT)
JRST VOLSW3 ;GO DO IT
VOLSW2: MOVEI AC4,2 ;INDICATE 2 ARGS
MOVEI AC3,4 ;INDICATE ARGS IN AC4,AC5
MOVEI AC5,.VSFST ;INDICATE GET FIRST REEL FUNCTION
VOLSW3: MTOPR% ;DO SWITCH****************
ERJMP MTOERR ;MTOPR ERROR, MESSAGE AND QUIT
TXO AC1,CO%NRJ ;INDICATE NOT TO RELEASE JFN
CLOSF% ;CLOSE THE JFN
ERJMP CLSERR ;ERROR GO DO IT
POPJ PP, ;RETURN
; THIS ROUTINE CHECKS FOR OPENF ERROR WHERE FILE IS
; ALREADY OPEN. IT RETURNS IN THIS CASE.
; ALL OTHER OPEN ERRORS DIE WITH ERROR MESSAGE.
; ASSUMES: AC3 SAVES JFN
; AC1 CONTAINS OPENF ERROR CODE
; CALLED WITH ERCAL JSYS
OPNFER: CAIE AC1,OPNX1 ;SKIP IF JFN ALREADY OPEN
JRST OJFERR ;OTHER ERROR,MESS AND QUIT
MOVE AC1,AC3 ;RESTORE JFN
POPJ PP, ; RETURN TO CALLER WITH JFN RESTORED
>;END IFN TOPS20
IFE TOPS20,<
;
; VOLSWT IS A ROUTINE TO SWITCH MTA REELS WHEN UNDER
; PULSAR CONTROL,BUT WITH NO MONITOR LABELING.
;
;
; USES: AC1,AC2,AC3
;
VOLSWT: MOVE AC1,[2,,2] ; 2 ARGS START AT AC2
MOVEI AC2,.TFFEV ; DENSITY AGAIN
LDB AC3,DTCN. ; GET CHANNEL NUMBER
TAPOP. AC1, ; GET THE UNIT DEFAULT
JRST [POP PP,(PP) ; TAPOP. ERROR
JRST VSWERR] ; GIVE IT
POPJ PP, ;RETURN
>;END IFE TOPS20
CLSR2A:
IFE TOPS20,<
TLNN FLG1,MSTNDR+MTNOLB ; PULSAR LABEL PROCESSING?
JRST CLSR2X ; NO,CONT
PUSHJ PP,VOLSWT ; YES, CHANGE VOLUMES
>;END IFE TOPS20
IFN TOPS20,<
TLNE FLG1,MSTNDR ; SYS-LABELED?
POPJ PP, ; YES, NOOP FROM HERE, RETURN
TLNN FLG1,MTNOLB ;MOUNTR AND NO LABELING?
JRST CLSR2X ;NO, GO ON
MOVEI AC4,.VSMRV ;YES,INDICATE GET NEXT REEL
PUSHJ PP,VOLSWT ;SWITCH
>;END IFN TOPS20
JRST CLOSR4 ;RELEASE AND REOPEN
CLSR2X:
OUTSTR [ASCIZ/
$ Mount/]
TLNN FLG,OPNIN ;SKIP IF INPUT
JRST CLOSR3 ;JUMP IF OUTPUT
PUSHJ PP,MSDTRN ;"REEL N"
OUTSTR [ASCIZ/ of/]
MOVE AC2,[BYTE (5)10,31,20,24,14]
PUSHJ PP,MSOUT. ;"FILE ON DEV" STOP0
JRST CLOSR4 ;OPEN THE NEXT REEL
CLOSR3: OUTSTR [ASCIZ/ scratch tape on/]
PUSHJ PP,MSDEV. ;DEVICE
PUSHJ PP,C.STOP ;TYPE CONT TO PRO
CLOSR4: TLZ AC16,777675 ;CLEAR ALL BUT REWIND & WRITE-REEL-CHANGE FLAGS
TXO AC16,V%OPEN!CLS%BV!CLS%RO ;OPEN WITH A REWIND + FLAG THE REEL CHANGE
PUSHJ PP,FRECHN ;NOTE THE CHAN IS FREE
XCT URELE. ;RELEASE THE DEVICE
JRST OPNDEV ;OPEN THE NEXT REEL
;READ A LABEL INTO THE RECORD AREA OR ZERO IT. ***@POPJ***
CLSRL: TLNN FLG,ATEND ;SKIP IF AT END
POPJ PP, ;
TXNE AC13,DV.MTA ;SKIP IF NOT A MAGTAPE
TXNN FLG1,B%STL ;SKIP IF NOT OMITTED LABELS
POPJ PP, ;ZERO THE RECORD AREA
IFE TOPS20,< ;[561]
XCT UCLOS. ;[561] CLEAR THE EOF
> ;[561]
PUSHJ PP,READSY ;READ A LABEL
JRST BUFREC ;NORMAL RETURN
CLSRL0: MOVEI AC0,FE%32 ;ERROR NUMBER
PUSHJ PP,IGCV ;IGNORE ERROR?
JRST CLSRL2 ;NO
TXNE AC16,V%READ ;YES READ UUO?
POPJ PP, ;YES, JUST RETURN
TXNN AC16,V%OPEN ;OPEN UUO?
JRST CLSRL1 ;NO MUST BE CLOSE
XCT URELE. ;RELEASE DEVICE
POP PP,(PP) ;DUMP RET TO BUFREC
JRST FRECHN ;RELEASE THE CHANNEL
; AND BACK TO CBL-PRG
CLSRL1: POP PP,(PP) ;POP OFF RET TO CLSRLB
TXO AC16,CLS%NR ;REWIND CAUSE WE'RE LOST
JRST CLOSE8 ;FINISH UP
CLSRL2: OUTSTR [ASCIZ/ Read an "EOF" instead of a label./] ;
MOVE AC2,[BYTE(5)30,10,31,20,37] ;CLOSE
TXNE AC16,V%OPEN ;OPEN?
MOVE AC2,[BYTE(5) 30,10,31,20,2] ;YES
TXNE AC16,V%READ ;READ?
MOVE AC2,[BYTE (5)35,31,20,10,4] ;YES
JRST MSOUT. ;GO COMPLAIN
;CHECK FOR "EOV" AS FIRST THREE LABEL CRARACTERS
CLSEOV: TLNE FLG,CDMASC ;SKIP IF NOT ASCII RECORD AREA
JRST CLSEO1 ;ASCII TEST
HLRZ C,(FLG) ;FIRST 3 CHARS
CAIN C,'EOV'
POPJ PP, ;OK EXIT
JRST RET.2 ;ERROR SKIP RET
CLSEO1: MOVE C,(FLG) ;FIRST WORD
TRZ C,77777 ;CLEAR EXTRANEOUS BITS
CAMN C,[ASCIZ /EOV/]
POPJ PP, ;OK EXIT
JRST RET.2 ;ERROR SKIP EXIT
;CLOSE & RELEASE THE INDEX FILE
CLSIDX:
IFN ISTKS,< ;TYPE OUT # OF IN'S AND OUT'S
MOVEI AC3,INSSSS(I12)
MOVEI AC2,OUTSSS(I12)
OUTSTR [ASCIZ /IN'S OUT'S
/]
CLSID0: MOVE AC0,(AC3)
SETZM (AC3)
PUSHJ PP,PUTDEC
MOVEI C," "
OUTCHR C
MOVE AC0,(AC2)
SETZM (AC2)
PUSHJ PP,PUTDEC
OUTSTR [ASCIZ /
/]
ADDI AC3,1
ADDI AC2,1
CAIE AC3,INSSSS+15(I12)
JRST CLSID0
OUTSTR [ASCIZ /FAKER.:=/]
MOVE AC0,(AC2)
PUSHJ PP,PUTDEC
SETZM (AC2)
OUTSTR [ASCIZ /
FORCR.:=/]
MOVE AC0,(AC3)
PUSHJ PP,PUTDEC
SETZM (AC3)
OUTSTR [ASCIZ /
/]
>
HRRZ AC1,D.IBL(I16) ; [377] GET ISAM SAVE AREA
JUMPE AC1,CLSID3 ; [377] NONE GO ON
HRLI AC1,ISCLR1(I12) ; [377] SAVE SHARE BUFFER AREA
MOVEI AC2,ISMCLR(AC1) ; [377] IN ISAM FILE SAVE AREA
BLT AC1,(AC2) ; [377]
CLSID3: ; [377] NEW LABEL
PUSHJ PP,SETIC ;SET THE CHANNEL NUMBER
SKIPE PRGFLG ;DELETE THE FILE
JRST CLSID2 ;YES SO GO DO IT
REPEAT 0,<
TLNE FLG,OPNOUT ;OPEN FOR OPTPUT?
JFCL; PUSHJ PP,WSTBK ;WRITE THE STATISTICS BLOCK
>
XCT ICLOS ;
XCT IWAIT ;WAIT FOR ERRORS
XCT IGETS ;GET STATUS
TXNE AC2,IO.ERR ;SKIP IF ANY ERRORS
PUSHJ PP,WIBK2 ;CATCH ANY ERRORS NOW
JRST CLSID1 ;
CLSID2: PUSHJ PP,OPNEIX ;
SETZM UEBLK. ;ZERO THE FILENAME
XCT IRNAM ;DELET
JRST CLSID4 ;ERROR RET
CLSID1: XCT IRELE ;
POPJ PP,
CLSID4: PUSHJ PP,ORERRI ;TRY FOR A USE PROCEDURE
POP PP,(PP) ;POP OFF CALL FROM CLOSF4+7
JRST CLOS72 ;CLEAN UP AND EXIT
;WRITE OUT ALL ACTIVE ISAM DATA STILL IN CORE
CLSISM: PUSHJ PP,SETIC ;SET INDEX FILE CHAANNEL NUMBER
SKIPE LIVE(I12) ;IF ANY ACTIVE DATA
PUSHJ PP,WWDBK ; OUTPUT IT
MOVE AC13,D.DC(I16) ;RESTORE AC13 ALIAS LVL
JRST CLOSE7
;CREATE A LABEL OR ZERO IT. ***@POPJ***
CLSCAL: TXNE AC13,DV.MTA ;SKIP IF DEVICE IS NOT A MTA
TXNN FLG1,B%STL ;SKIP IF STANDARD LABELS
POPJ PP, ;CLEAR RECORD AREA
JRST OPNCAL ;CREATE A LABEL FOR A MTA W/ STD LABELS
;WRITE AN ENDING LABEL AND DO FINAL ERROR CHECKS. ***@POPJ***
CLSWEL: SKIPE PRGFLG ;[576] SKIP IF NOT CLOSE WITH DELETE
IFN TOPS20,< ;[1005] TOPS-10 MUST FREE RETAINED RECORDS
JRST CLSWL1 ;[576] SKIP BUFFER SAVES,DELETE FOLLOWS
> ;[1005]
IFE TOPS20,<
JRST CLSPRG ;[1005] JUMP TO FREE RETAINED RECORDS
SKIPN F.WSMU(I16) ;[576] SKIP IF RETAINED RECORDS
JRST CLSWLX ;[576] NOT RETAINED, GO ON
LDB AC0,DTCN. ;[576] GET CHANNEL NUMBER
HRLM AC0,FUSCP. ;[576] SET CHAN NUMBER IN ARG BLK
MOVE AC0,[1,,FUSCP.] ;[576] INDICATE CHECKPOINT ARG BLK
FILOP. AC0, ;[576] DO .FOURB CHECKPOINT FILOP,CLEARING OUT FILE
PUSHJ PP,CKPTER ;[576] ERROR IN CHECK POINT FILOP
PUSHJ PP,CLWSMU ;[576] FREE ALL RETAINED BLOCKS
TLNN FLG,IDXFIL ;[576] SKIP IF INDEX FILE
JRST CLSWLX ;[576] NOT INDEX, GO ON
MOVE AC0,ICHAN(I12) ;[576] GET INDEX FILE CHAN NUMBER
HRLM AC0,FUSCP. ;[576] SET CHAN NUMBER
MOVE AC0,[1,,FUSCP.] ;[576] INDICATE ARG BLK
FILOP. AC0, ;[576] CHECKPOINT INDEX FILE
PUSHJ PP,CKPTER ;[576] ERROR IN FILOP
JRST CLSWLX ;[576] CONTINUE
CKPTER: MOVE AC0,[E.VCLO+E.MFOP] ;[576] INDICATE CLOSE FILOP ERROR
TLNN FLG,IDXFIL ;[576] INDEX FILE?
JRST CKPTR1 ;[576] NO, SKIP AHEAD
PUSHJ PP,IGMI ;[576] IGNORE ERROR?
JRST CKPTR2 ;[576] NO, GIVE ERROR MESS
JRST CLRIS ;[576] YES,CLEAR ERROR STATUS AND RETURN TO CALL
CKPTR1: PUSHJ PP,IGMD ;[576] NON-INDEX FILE ,IGNORE ERROR?
JRST CKPTR2 ;[576] NO
JRST CLRDS ;[576] YES, CLEAR ERROR STATUS AND CONTINUE
CKPTR2: XCT UWAIT. ;[576] WAIT ON ERRORS
MOVE LVL,D.DC(I16) ;[576] SET DEVICE CHARACTERISTICS
PUSHJ PP,IOERMS ;[576] SET ERROR CODES
MOVE AC2,[BYTE(5) 10,37,31,20,4] ;[576] INDICATE MESSAGE
JRST MSOUT. ;[576] MESSAGE AND KILL
CLSPRG: SKIPN F.WSMU(I16) ;[1005] SKIP IF RETAINED RECORDS
JRST CLSWL1 ;[1011]
PUSHJ PP,CLWSMU ;[1005] YES, FREE THEM ALL
CLSWLX:>;[576] END IFE TOPS20
IFN TOPS20,<
TXNE FLG1,B%NIO ;NATIVE I/O?
JRST [HRRZ AC1,D.JFN(I16)
TXO AC1,CO%NRJ ;DON'T RELEASE JFN YET
CLOSF%
HALT
JRST CLSWL2] ;OK
>
XCT UCLOS. ;[576] DUMP ALL THE BUFFERS
CLSWL1: PUSHJ PP,WRTWAI ;[576] WAIT FOR ERROR CHECKING
IFN TOPS20,<
CLSWL2: SKIPE F.WSMU(I16) ;[576] [571] ANY RETAINED RECORDS?
PUSHJ PP,CLWSMU ;[576] SMU, FREE RETAINED BLOCKS
>;[576] END IFN TOPS20
CLSWLA: TXNE AC13,DV.MTA ;[573] SKIP NOT A MAGTAPE
TXNN FLG1,B%STL ;SKIP IF LABELS ARE NOT OMITTED
POPJ PP, ;
XCT UOUT. ;DUMMY OUTPUT
PUSHJ PP,RECBUF ;MOVE RECORD TO THE BUFFER AREA
PUSHJ PP,WRTOUT ;OUTPUT IT
XCT UCLOS. ;LEOT
JRST WRTWAI ;WAIT FOR ERROR CHECKING
;[576] GO DEQUEUE AND RETAINED RECORDS AFTER SAVING FLG REGS
CLWSMU: PUSH PP,FLG ;[576] [573] SAVE FLG, SU.CL KILLS IT
PUSH PP,FLG1 ;[576] [573] SAVE THIS TOO
PUSHJ PP,SU.CL ;[576] [571] YES, DEQUEUE THEM
POP PP,FLG1 ;[576] [573] RESTORE FLG1 AND
POP PP,FLG ;[576] [573] NOW GET FLG BACK
POPJ PP, ;[576] RETURN
;TO KEEP OUR MTA BUFFERS STRAIGHT. ***POPJ***
IFE TOPS20,<
CLSYNC: XCT UGETS. ;SET OR CLEAR
TRC AC2,IO.SYN ; THE SYNCHRONOUS
XCT USETS. ; MODE STATUS BIT
POPJ PP, ; FOR MAGTAPE
>;END IFE TOPS20
;ZERO THE UNUSED AREA OF THE DUMP MODE BUFFER
CLSZBF: TLNN FLG,DDMEBC!DDMASC ;[665] SKIP IF AN EBCDIC/ASCII FILE
JRST CLSZB2 ; JUMP ITS NOT
HLRZ AC1,R.BPNR(I12) ; PAD THE LAST RECORD WORD
LSH AC1,-^D12 ;[665] ISOLATE BIT COUNT
CAIN AC1,44 ;[665] DID REC END ON A WORD BOUNDARY ?
JRST CLSZB2 ; YES
MOVE AC1,R.BPNR(I12) ; GET BYTE-PTR
TDZA AC2,AC2 ; THE PAD CHAR
IDPB AC2,AC1 ;
TLNE AC1,760000 ;[665] DONE?
JRST .-2 ; LOOP
AOS R.BPNR(I12) ; RESTORE BYTE-PTR
CLSZB2: HRRZ AC1,R.BPNR(I12) ;LOC
SUB AC1,R.IOWD(I12) ;LOC - LOC-1
HLRZ AC2,AC1 ;LENGTH
SUBI AC2,(AC1) ;LENGTH TO CLEAR
JUMPE AC2,RET.1 ; EXIT IF NOTHING TO ZERO
HRR AC1,R.BPNR(I12) ;LOC
HRL AC1,AC1 ;FROM
HRRI AC1,1(AC1) ;TO
SETZM -1(AC1) ;THE ZERO
ADDI AC2,-1(AC1) ;UNTIL
CAIL AC2,(AC1) ;JUST EXIT IF BUFFER IS FULL
BLT AC1,(AC2) ;DOIT
POPJ PP,
SUBTTL NATIVE MODE CLOSE
IFN TOPS20,<
;CLOSE for simple output device such as LPT:
CLSLPT: SETZM PRGFLG ;WE CAN'T PURGE LPT FILES
TXNE AC16,CLS%CR ;CLOSE REEL?
POPJ PP, ;YES, IGNORE & CONTINUE
TXO AC16,CLS%EF ;%CLOSE FILE
HLRZ AC12,D.BL(I16) ;BUFFER LOCATION
HRRZ AC4,D.RFLG(I16) ; NO, GET STD ASCII FLAG
TRZE AC4,AFTADV ; SKIP IF DON'T NEED 'CR'
;If you don't want the extra <cr> at the end of the file
;replace the instruction at NOXCR. by a JFCL
;However that is contrary to the ANSI-74 standard as interpreted by the FCTC.
XCT NOXCR. ; WRITE 'CR'
HRRM AC4,D.RFLG(I16) ; RESET FLAG
SKIPGE D.OBB(I16) ; SKIP IF BUFFER MIGHT HAVE DATA(NOT 44S00,LOC)
JRST CLSLP1 ; NO LONGER PAD LOGICAL BLOCKS
HRRZ AC1,D.OBH(I16) ; GET BUF HDR ADDR
HRRZ AC3,D.OBB(I16) ; GET BYTE PTR LOC ADDR
CAIE AC1,-1(AC3) ; SKIP IF AT BEGIN OF BUFFER
PUSHJ PP,WRTBUF ; WRITE OUT LAST BUFFER
CLSLP1: HRRZ AC1,D.JFN(I16)
TXO AC1,CO%NRJ ;DON'T RELEASE JFN YET
CLOSF%
HALT
SETZM D.DC(I16) ;DEVICE CHARACTERISTICS
TLZ FLG,OPNIN+OPNOUT+ATEND+NOTPRS+CONNEC
MOVEM FLG,F.WFLG(I16) ;REINITIALIZE THE FLAGS
TLZ FLG1,F1CLR ; CLEAR SOME FLAGS
HLLM FLG1,D.F1(I16) ;REINIT MORE FLAGS
MOVX AC0,RF1CLR ; GET MORE FLAGS
ANDCAM AC0,D.RFLG(I16) ; TO CLEAR
HRRZS AC1,D.JFN(I16) ;CLEAR JFN
RLJFN%
HALT
PJRST CLRSTS ;CLEAR FILE STATUS WORD AND EXIT TO THE COBOL PROGRAM
;CLOSE for simple input device such as CDR:
CLSCDR: SETZM PRGFLG ;WE CAN'T PURGE CDR FILES
TXNE AC16,CLS%CR ;CLOSE REEL?
POPJ PP, ;YES, IGNORE & CONTINUE
TXO AC16,CLS%EF ;%CLOSE FILE
JRST CLSLP1 ;JOIN COMMON CODE
>
SUBTTL WRITE VERB
;HERE FOR WRITE VARIABLE LENGTH RECORDS.
; ROUTINES WADVV. AND WRITV. CORRESPOND TO WADV. AND WRITE.
; EXCEPT THE RECORD SIZE IS GIVEN IN AC15
WADVV.: TXOA AC16,V%WADV ;WRITE ADVANCE
WRITV.: TXO AC16,V%WRITE ;WRITE
PUSH PP,AC15 ;SAVE RECSIZE
SETZM NOCR. ;CLEAR NO CARRIAGE RET FLAG
MOVE AC0,[FS.ZRO,,FS.FS];ZERO THE ERROR
BLT AC0,FS.IF ; STATUS WORDS.
SKIPE F.WSMU(I16) ;ANY RETAINED RECORDS?
PUSHJ PP,SU.WR ; YES
HRRZ AC15,-1(PP) ;OPERAND OR RETURN ADR (UOCAL.)
MOVE AC15,(AC15) ;
PUSHJ PP,WRTSUP ;SETUP
POP PP,AC3
DPB AC3,WOPRS. ;PUT RECORD SIZE IN AC15
JRST WRTGT3 ;GO JOIN REGULAR WRITE CODE
SUBTTL WRITE VERB
;A WRITE. VERB LOOKS LIKE:
;FLAGS,,ADR WHERE ADR = FILE TABLE ADDRESS
;CALL+1: 0-11 RECORD SIZE IN CHARACTERS
; 12-35 UNDEFINED
;CALL+2: NORMAL POPJ RETURN
;CALL+3: "INVALID-KEY" RETURN
;A WADV. VERB LOOKS LIKE:
;FLAGS,,ADR WHERE ADR = FILE TABLE ADDRESS
;CALL+1: 0-11 RECORD SIZE IN CHARACTERS
;BIT12 =1 USE 18-35 AS AN ADDRESS
;BIT13 =0 WRITE AFTER ADVANCING
;BIT13 =1 WRITE BEFORE ADVANCING
;BIT14 =1 IF POSITIONING
;BIT15-17 ADVANCE VIA THIS LPT CHANNEL
;BIT18-35 NUMBER OF TIMES TO ADVANCE
;
;
; IF BIT12=1 (18-35 IS ADDR) AND
; BIT18-35= -1 THEN ADVANCING IS DEFAULT
;CALL+2: NORMAL POPJ RETURN
;SETUP AND INITIAL CHECKS. ***WRTREC***RANDOM***
WRPW.: TXO AC16,V%WADV ; WRITE ADVANCE VERB
SETOM NOCR. ;REPORT-WRITER ENTRY
JRST WRITE1 ;
WADV.: TXOA AC16,V%WADV ;WRITE ADVANCE
WRITE.: TXO AC16,V%WRITE ;WRITE
SETZM NOCR. ;CLEAR NO CARRIAGE RET FLAG
WRITE1: MOVE AC0,[FS.ZRO,,FS.FS];ZERO THE ERROR
BLT AC0,FS.IF ; STATUS WORDS.
SKIPE F.WSMU(I16) ;ANY RETAINED RECORDS?
PUSHJ PP,SU.WR ; YES
SKIPGE NOCR. ;IF THIS IS A REPORT WRITER CALL
JRST WRITE2 ;AC15 IS ALREADY SETUP
HRRZ AC15,(PP) ;OPERAND OR RETURN ADR (UOCAL.)
MOVE AC15,(AC15) ;
WRITE2: PUSHJ PP,WRTSUP ;SETUP
LDB AC3,WOPRS. ;RECORD SIZE FROM AC15
WRTGT3: MOVEI AC0,RDLAST ;TURN OFF VALID READ FLAG
ANDCAM AC0,D.RFLG(I16)
TLNN FLG,OPNOUT ;SKIP IF OPEN FOR OUTPUT
JRST ERROP3 ;ERROR MESSAGE
TLNE FLG,IDXFIL ;
JRST IWRITE ;WRITE AN INDEX-FILE
;SEQ AND REL/SEQ WRITE ALLOW OPN OUTPUT ONLY
TLNN FLG,RANFIL ;RANDOM FILE ?
JRST WRITE3 ;NO, SEQ
LDB AC0,F.BFAM ;YES,GET ACCESS MODE
CAIN AC0,%FAM.S ;RANDOM OR DYNAMIC SKIPS
TLNN FLG,OPNIN ;[622] SEQ, OPEN FOR I-O?
JRST RANDOM ;NO, DO RANDOM OR I-O
JRST ERROPN ;YES, ERROR-WRITE OUTPUT ONLY
WRITE3: TLNE FLG,OPNIN ;[622] SEQ. ORGAN.,OPEN I-O?
JRST ERROPN ;YES, ERROR ALSO
TLNE FLG,IOFIL ;[622] SKIP IF NOT AN I-O DUMP MODE FILE
JRST RANDOM ;[622] ELSE DO DUMP MODE WRITE
JUMPL FLG,WRTREC ;ASCII
TLNE FLG,DDMBIN ;IF BINARY,
JRST WRTR20 ; USE THIS ROUTINE
TLNE FLG,DDMEBC ;EBCDIC?
JRST WER ;YES - USE EBCDIC ROUTINE
;CHECK AND WRITE OUT VARIABLE LENGTH RECORD SIZE
PUSHJ PP,WRTABP ;ADJUST THE BYTE-POINTER
MOVE AC4,D.RP(I16) ;GET RECORD SEQUENCE NUMBER
TXNE AC13,DV.MTA ;MTA?
HRLM AC4,(AC1) ;YES - STORE IN THE HEADER WORD
HRRM AC3,(AC1) ;MOVE RECSIZE TO THE BUFFER
AOS D.OBB(I16) ;SO REC-SIZE IS NOT OVERWRITTEN
MOVN AC4,D.BPW(I16) ;MAKE BYTE COUNT
ADDB AC4,D.OBC(I16) ; RIGHT
JUMPN AC4,WRTREC ;JUMP IF BUFFER IS NOT FULL
TLNN FLG,CONNEC ;SKIP IF CONVERSION IS NECESSARY
SOS D.OBB(I16) ;BACKUP THE BYTE-POINTER
PUSHJ PP,WRTBUF ;ADVANCE BUFFERS
PUSHJ PP,WRTABP ;ADJUST BYTE-POINTER
;MOVE RECORD TO THE BUFFER, OUTPUT IF NECESSARY.
WRTREC: TLNN FLG,CONNEC ;SKIP IF CONVERSION IS NECESSARY
JUMPGE FLG,WRTRB ;NO, ASCII, GO BLT RECORD
MOVE AC10,D.WCNV(I16) ;SETUP AC10
TXNN AC16,V%WADV ;SKIP IF WADV
JRST WRTRCA ; NO ADVANCING
TLNE AC15,WDVBFR ; ADV BEFORE?
JRST WTRC01 ; YES, JUMP
MOVEI AC4,AFTADV ; NO, GET AFT-ADV ASCII FLAG
IORM AC4,D.RFLG(I16) ; SET IT
JRST WTRC00 ; CONT
; HERE IF BEFORE-ADV ,BEFORE WRITING THE RECORD WRITE "CR"?
WTRC01: TXNE AC13,DV.MTA ; IS THIS MTA?
JRST WTRC00 ; YES, SKIP FUNNY EXTRA "CR"
HRRZ AC4,D.RFLG(I16) ; GET STANDARD ASCII FLAG
TRZE AC4,AFTADV ; SKIP IF DON'T NEED "CR"
PUSHJ PP,WRTCR ; WRITE "CR"
HRRM AC4,D.RFLG(I16) ; RESET IT
WTRC00: PUSHJ PP,WRTADV ;SEE IF NOW IS THE TIME TO ADVANCE
TRNA ;NORMAL RETURN
AOS (PP) ;COPY END OF PAGE SKIP RETURN
JRST WRTRCB ; CONT
WRTRCA: JUMPGE FLG,WRTRCB ; JUMP THIS IF NOT ASCII
HRRZ AC0,D.RP(16) ;[1171] IS THIS THE FIRST RECORD?
JUMPLE AC0,WRTRCB ;[1171] IF SO, DON'T OUTPUT CRLF
; IF STD-ASCII AND MTA, THEN NO CR-LF
HRRZ AC4,D.RFLG(I16) ; GET STANDARD ASCII FLAG
TRO AC4,AFTADV ; SET AFT-ADV DONE
HRRM AC4,D.RFLG(I16) ; RESET
TRNE AC4,SASCII ; SKIP IF NOT STANDARD ASCII
TXNN AC13,DV.MTA ; STD-ASCII AND MTA?
PUSHJ PP,WRTCRLF ; NO, THEN WRITE CR-LF
; YES, NO CRLF
WRTRCB: JUMPE AC3,WRTZRE ;TRYING TO WRITE A NULL REC?
;SUPPRESS TRAILING BLANKS FOR ASCII OUTPUT FILES IF REQUIRED
SKIPN SUPTB. ; COBOL SYNTAX TO SUPPRESS TRAILING BLANKS SEEN?
JRST WRTSIX ; NO
JUMPGE FLG,WRTSIX ; [403] IF NOT ASCII DO REGULAR WRITE
TXNE AC13,DV.MTA ;[CCS1] Do regular write for MTA also
JRST WRTSIX ;[CCS1]
SETZB AC4,AC5 ; [403] SET UP SIXBIT BLANK AND BLANK CNT
TLNN FLG,CONNEC ; [403] IF CONVERSION NOT NEEDED IT IS ASCII RECORD
MOVEI AC4," " ; [403] ASCII BLANK
WRTRA0: ILDB C,AC6 ;[CCS-1]CHAR FROM THE RECORD AREA
CAIE C,(AC4) ; [403] IS IT BLANK?
JRST WRTRA1 ; [403] NO
AOS AC5 ; [403] YES CNT NO OF THEM IN SUCCESSION
SOJG AC3,WRTRA0 ;[CCS-1] [403] GET NEXT CHAR
LDB AC4,WOPRS. ; [403] END OF RECORD- GET BACK RECORD SIZE
SUB AC4,AC5 ; [403] GET NUMBER OF CONSECUTIVE BLANKS
JUMPG AC4,WRTRA3 ; [403] WROTE AT LEAST ONE CHAR FINISH UP
MOVEI C," " ; [403] RECORD ALL BLANKS; MUST OUTPUT ONE
JRST WRTRAA ; [403] INSERT ONE BLANK AND FINISH
WRTRA1: JUMPE AC5,WRTRA2 ; [403] NO INTERVENING BLANKS GO ON
MOVEI AC1," " ; [403] ASCII BLANK
BLKINS: IDPB AC1,D.OBB(I16) ; [403] Insert a blank
SOSG D.OBC(I16) ; [403] Is there is room in the buffer?
PUSHJ PP,WRTBUF ; [403] No, write it out
SOJG AC5,BLKINS ; [403] Write next blank
WRTRA2: XCT AC10 ;CONVERT IF NECESSARY
WRTRAA: IDPB C,D.OBB(I16) ;CHAR TO THE BUFFER
SOSG D.OBC(I16) ;Skip if the buffer is not full
PUSHJ PP,WRTBUF ;Buffer full, write it out
SOJG AC3,WRTRA0 ;LOOP TILL A COMPLETE RECORD IS PASSED
WRTRA3: ;[WADV]
JRST WTRE2A ;[CCS-1] Rejoin main code
WRTSIX: TLNE FLG1,MSTNDR ; IS THIS LABELED TAPE?
PUSHJ PP,PADLAB ; YES,CHECK PADDING
;[R672] WRTRE1: SOSL D.OBC(I16) ;[655][653]SKIP IF YOU CAN
;[R672] JRST WRTR1A ;[655] OVER THE PUSHJ
;[R672] PUSHJ PP,WRTBUF ;[653]BUFFER FULL, WRITE IT OUT
;[R672] SOS D.OBC(I16) ;[655]ADJUST COUNT FOR THIS BYTE
;[R672] WRTR1A: ILDB C,AC6 ;[655]CHAR FROM THE RECORD AREA
WRTRE1: ILDB C,AC6 ;[672]CHAR FROM THE RECORD AREA
XCT AC10 ;CONVERT IF NECESSARY
IDPB C,D.OBB(I16) ;CHAR TO THE BUFFER
SOSG D.OBC(I16) ;[672] SKIP IF YOU CAN
PUSHJ PP,WRTBUF ;[672] BUFFER FULL, WRITE IT OUT
SOJG AC3,WRTRE1 ;LOOP TILL A COMPLETE RECORD IS PASSED
JUMPGE FLG,WRTRE4 ;JUMP IF NOT ASCII
WRTRE2: TLNE FLG1,MSTNDR ; LABELED TAPE?
PUSHJ PP,LABPAD ; YES, PAD OUT AS INDICATED BY STACK
WTRE2A: TXNN AC16,V%WADV ;SKIP IF WADV
JRST WRTRE6 ; ELSE DO CR-LF
PUSHJ PP,WRTADV ;WADV.
JRST WRTRE6 ;[1125] NORMAL RETURN
SKIPN RPTW.## ;[1125] SKIP RETURN, DOING RPTW?
AOS (PP) ; NO, COPY END-OF-PAGE SKIP RETURN
SETZM RPTW.## ;[1125] SET FLAG TO ZERO
JRST WRTRE6 ; CONT
; PADLAB ROUTINE TO SAVE PAD LENGTH FOR F FORMAT LABELED MTA
; (AC3 CONTAINS THE WRITE RECORD LENGTH)
;
; USES AC0,AC1,AC2
;
; RETURNS +1 ALWAYS, PAD LENGTH PUSHED ONTO STACK
PADLAB: LDB AC1,F.BFMT ; GET FORMAT FIELD
TRNN AC1,FRMATF ; F FORMAT?
JRST PADLBX ; NO, GO ON,0 LEFT INDICATES 0 PAD
LDB AC0,F.BMRS ; GET MAX REC SIZE
SUBI AC0,(AC3) ; CALC PAD LENGTH
HRR AC1,AC0 ; SET HERE
PADLBX: POP PP,AC2 ; POP RETURN ADDRESS
PUSH PP,AC1 ; AND SAVE PAD-LEN,,FRMAT-BITS
JRST (AC2) ; RETURN
; LABPAD ROUTINE TO PAD OUT SYS-LABELED MTA REC WITH NULLS
;
; USES AC1,C PAD-LEN,,FRMAT-BITS (ON STACK) ARE POPPED
;
;
LABPAD: POP PP,AC2 ; GET RETURN ADDR
POP PP,AC1 ; RESTORE PAD-LEN,,FRMAT-BITS
TLNN AC1,-1 ; SKIP IF SOME PADDING
JRST LABPDX ; NOP, CONT
HLRZ AC1,AC1 ; GET PADDING COUNT
SETZ C, ; GET NULL
IDPB C,D.OBB(I16) ; CHAR TO THE BUFFER
SOJG AC1,.-1 ; LOOP TILL PADDED, ASSUME
; F FORMAT MUST BE BLOCKED,
LABPDX: JRST (AC2) ; SO WILL FIT IN ONE BUFF
;ZERO FILL THE LAST PARTIAL WORD IF NECESSARY
WRTRE4: SKIPN AC2,D.OBC(I16) ;SKIP IF BUFFER IS NOT FULL
JRST WRTRE6 ;JUMP FULL
WRTRE5: MOVE AC1,D.OBB(I16) ;OUTPUT BYTE POINTER
TLNN AC1,760000 ;SKIP IF ZERO FILL IS NECESSARY
JRST WRTRE7 ;
IBP D.OBB(I16) ;FILL IN A ZERO
SOSLE D.OBC(I16) ;ADJ THE BYTE COUNT
JRST WRTRE5 ;LOOP
WRTRE6: SKIPG D.OBC(I16) ;BUFFER FULL?
PUSHJ PP,WRTBUF ;YES
;STANDARD EXIT FOR READ AND WRITE. ***POPJ***
;MAY GENERATE A CLOSE UUO IF A MTA "EOT" AND A MULTI REEL FILE.
WRTRE7: SETZM NRSAV.+4 ; CLEAR SAVED ACTUAL KEY
PUSHJ PP,CLRSTS ;[601] CLEAR FILE STATUS WORD
LDB AC2,F.BBKF ;BLOCKING-FACTOR
JUMPE AC2,WRTR10 ;DON'T PAD IF BLK-FTR IS ZERO
TLNN FLG,IOFIL+RANFIL ;[622] SKIP IF AN IO/RANDOM FILE
SOSE D.RCL(I16) ;DECREMENT THE RECORD/LOGICAL-BLOCK COUNT
JRST WRTR10 ;
MOVEM AC2,D.RCL(I16) ;RECORDS/LOGIC BLOCK
SETZM D.IBC(I16) ;BE SURE THE NEXT READ GETS NEXT BUFFER
SKIPLE AC2,D.BCL(I16) ;BUFFERS/LOGICAL BLOCK
WRTRE9: SOJGE AC2,WRTR14 ;PASS A BUFFER AND RETURN HERE
MOVE AC2,D.BPL(I16) ;RESTORE
MOVEM AC2,D.BCL(I16) ; BUFFERS PER LOGICAL BLOCK
WRTR10: LDB AC0,F.BCRC ; GET CHP=PNT REC CNT
JUMPE AC0,WTR10A ; SKIP IF NONE
TXNE AC16,V%DLT+V%RWRT+V%WRITE+V%WADV ; IS THIS DELET,RERIT,WRITE?
PUSHJ PP,CKPREC ; YES, DECR. COUNT AND CHKPNT IF TIME
WTR10A: PUSHJ PP,CHKRRN ; CHECK FOR RERUN OR FORCED DUMP
SKIPN F.WSMU(I16) ;[1064] DOING SIMULTANEOUS UPDATE?
JRST WRTR11 ;[1064] NO
SKIPN SU.FRF ;[1064] DOING FAKE READ FOR SMU?
PUSHJ PP,LRDEQX## ;[1064] NO
WRTR11: TLNE FLG,RANFIL ;DONT MESS WITH OLD KEY (D.RP) IF RANFIL
JRST WTR11A ; IN WHICH CASE FORGET IT
HRRZ AC1,D.RFLG(I16) ; GET SOME FLAGS
TXNN AC1,RDDREV ; READ REVERSE OPEN ACTIVE?
JRST WTR11B ; NO CONT
SOS D.RP(I16) ; YES, DECREMENT COUNT
JRST WTR11A ; AND CONT
WTR11B: AOS D.RP(I16) ;BUMP THE RECORD COUNT
WTR11A: MOVEI AC0,RDLAST
TXNE AC16,V%READ ;DOING READ?
IORM AC0,D.RFLG(I16) ;YES, TURN ON VALID READ FLAG
TXNN AC16,V%READ!V%DLT ;SKIP IF READ OR DELETE
AOS (PP) ;
TXNN AC16,FL%EOT ;SKIP IF "EOT"
POPJ PP, ;EXIT TO THE ***"ACP"***
HRLI AC16,(V%CLOS+CLS%RO+CLS%CR) ;CLOSE REEL WITH REWIND
SKIPA AC1,FILES. ;THE FIRST FILE-TABLE
WRTR12: HRRZ AC1,F.RNFT(AC1) ;NEXT FILE-TABLE ADR
JUMPE AC1,C.CLOS ;NO MORE, EXIT TO THE ***ACP***
CAIN AC1,(I16) ;IS IT THE CURRENT FILE-TABLE?
JRST WRTR12 ;YES, LOOP
HRRZ AC2,F.RREC(AC1) ;RECORD-AREA ADR
CAIE AC2,(FLG) ;SKIP IF "SAME RECORD-AREA"
JRST WRTR12 ;ELSE LOOP
;SAVE THE SHARED RECORD-AREA WHILE CHANGING REELS
MOVEI AC1,15 ;STD LABEL SIZE IN WORDS (-1)
HRR AC2,.JBFF ;"TO" ADR
HRL AC2,FLG ;"FROM,,TO" ADRS
MOVE AC0,AC1 ;SETUP AC10 FOR GETSPC
PUSHJ PP,GETSPC ;GET SOME SPACE
JRST WCORER ;NO CORE AVAILABLE
PUSH PP,AC1 ;SAVE LENGTH POPED @ OPNDVC
PUSH PP,AC2 ;SAVE "FROM,,TO"
HRRZ AC0,HLOVL. ;GET START OF OVERLAY AREA
CAMGE AC0,.JBFF ;BLT INTO OVL AREA?
JUMPN AC0,WOVLER ;ERROR IF IT DOES
MOVE AC1,.JBFF ;"UNTIL"
BLT AC2,(AC1) ;SLURP!
WRTR13: HRLI AC16,(V%CLOS!CLS%RO!CLS%CR!FL%WRC) ;CLOSE REEL WITH REWIND AND FL%WRC FLAG SET
JRST C.CLOS ;DOIT!
; CHKRRN CHECKS FOR RERUN COUNT AND UPDATES IT IF INDICATED.
; WHEN IT HITS ZERO A RERUN DUMP WILL BE TAKEN BY CALLING RRDMP.
; A CKECK IS ALSO MADE FOR A FORCED (CONTROL-C EXIT WITH REENTER)
; DUMP.
CHKRRN: SOSG D.RRD(I16) ;SKIP IF IT'S NOT RERUN DUMP TIME
TXNN FLG,B%RRC ;SKIP IF WE ARE RERUNNING
JRST CKRRN1 ;
HRRZ AC2,F.RRRC(I16) ;RESTORE NUMBER OF RECORDS
MOVEM AC2,D.RRD(I16) ; TO A RERUN DUMP
JRST CKRRN2
CKRRN1: SKIPL REDMP. ;SKIP IF A FORCED DUMP
POPJ PP, ; NEITHER DUMP RETURN NOW
CKRRN2: PUSHJ PP,RRDMP ;DUMP
;RESTORE .JBSA, .JBREN - DESTROYED BY RERUN'S GETSEG
RSAREN: HRR AC2,RESET1
HRRM AC2,.JBSA
MOVEI AC2,RENDP
MOVEM AC2,.JBREN
POPJ PP,
;FORCE A CALL TO RRDMP
RENDP: SETOM REDMP. ;
IFN TOPS20,<
SAVACS ;[1206]SAVE ACS
MOVEI 1,.FHSLF ;[1206]SELF PROCESS HANDLE
MOVEI 2,XTDBLK ;[1206]ARG. BLOCK
XRIR% ;[1206]READ BLOCK
ERJMP [RSTACS
JRST @.JBOPC##];[1206]4.1 MONITOR... OLD WAY
MOVE 1,XTDBLK+1 ;[1206]GET TABLE ADDRESS
MOVE 1,(1) ;[1206]FIRST INDIRECTION...
MOVEM 1,SAVADR ;[1206]
RSTACS ;[1206]
XJRSTF @SAVADR
ERJMP .+1
>
JRSTF @.JBOPC ;CONTINUE
WOVLER: HRRZM AC2,.JBFF ;GET JOBFF OUT OF OVL-AREA
POP PP,(PP) ;MAKE THE STACK RIGHT SO
POP PP,(PP) ;WE CAN RETURN TO CBL-PRG
JRST WOVLR2
WOVLR1: EXCH AC5,.JBFF ;MOVE JOBFF
SUBM AC5,.JBFF ;BACK OUT OF OVL-AREA
WOVLR2: MOVEI AC0,FS%30 ;PERMANENT ERROR
MOVEM AC0,FS.FS ;LOAD FILE-STATUS
MOVEI AC0,FE%35 ;ERROR-NUMBER
PUSHJ PP,OXITP ;RETURNS TO CBL-PRG IF IGNORING ERRORS
WOVLRX: PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /Not enough free core between .JBFF and overlay area./]
WOVLRY: MOVE AC2,[BYTE (5)10,31,20,21,4]
TXNN AC16,V%READ ;GET THE RIGHT MESSAGE
MOVE AC2,[BYTE (5)10,31,20,22,4]
TXNE AC16,V%OPEN ;OPEN VERB?
MOVE AC2,[BYTE (5) 10,31,20,2]
JRST MSOUT. ;MESSAGE AND KILL
WCORER: MOVEI AC0,FS%30 ;PERMANENT ERROR
MOVEM AC0,FS.FS ;LOAD FILE-STATUS
HRRZM AC2,.JBFF ;BACK OUT OF OVERLAY AREA
MOVEI AC0,FE%8 ;ERROR NUMBER
PUSHJ PP,OXITP ;RETURNS FOR FATAL MESS
PUSHJ PP,GETSP9 ;GIVE MESSAGE
JRST WOVLRY ;AND KILL
;PAD THE LOGICAL BLOCK IF NECESSARY.
WRTR14: PUSH PP,AC2 ;SAVE PAD BUFF COUNT
TXNN AC16,V%READ ;SKIP IF READ
JRST WRTR17 ;A WRITE
PUSHJ PP,READBF ;INPUT A BUF AND SKIP EXIT
SETZM D.IBC(I16) ;REMEMBER THAT IT'S EMPTY
JRST WRTR18 ;[343]
WRTR17: TLNE FLG,DDMBIN ;[343] IF BINNARY LET NXT WRITE/CLOSE OUTPUT IT
JRST WRTR18
SKIPE F.PADD(I16) ;DID USER SUPPLY PADDING CHAR?
PUSHJ PP,PADBUF ;YES, PADD REST OF BUFFER WITH IT
PUSHJ PP,WRTBUF ;[343] OUTPUT A BUF
WRTR18: POP PP,AC2 ; RESTORE PAD BUFF COUNT
TLZE FLG,ATEND ;[343] EOF?
JRST WRTR10 ;GIVE HIM THE REC AND LET NXT READ GET EOF
JRST WRTRE9 ;RETURN
;WRITE OUT A BINARY RECORD
WRTR20: SKIPG D.OBC(I16) ;IF BUFFER IS FULL,
PUSHJ PP,WRTBUF ; WRITE IT OUT
MOVE AC11,AC3 ;GET RECORD SIZE IN BYTES
LDB AC12,[POINT 2,FLG,14] ; GET CORE DATA MODE
HRRZ AC12,RBPTBL(AC12) ; GET CHARS PER WORD
ADDI AC11,-1(AC12) ;CONVERT SIZE TO WORDS AND
IDIVI AC11,(AC12) ; ROUND UP
HRL AC5,FLG ;MOVING FROM RECORD AREA
WRTR21: HRR AC5,D.OBB(I16) ;MOVING TO BUFFER
ADDI AC5,1 ; PLUS ONE WORD
MOVE AC4,AC11 ;IF NOT
CAMLE AC4,D.OBC(I16) ; ENOUGH WORDS IN BUFFER,
MOVE AC4,D.OBC(I16) ; WE WILL DO A PARTIAL MOVE NOW
ADDM AC4,D.OBB(I16) ;BUMP BUFFER WORD ADDRESS
MOVN AC12,AC4 ;DECREMENT
ADDM AC12,D.OBC(I16) ; BUFFER COUNT
ADD AC11,AC12 ; AND NUMBER RECORDS WORDS LEFT
MOVS AC12,AC5 ;REMEMBER NEXT 'FROM',
ADD AC12,AC4 ; IT MAY BE NEEDED
ADDI AC4,(AC5) ;COMPUTE FINAL DESTINATION ADDRESS, PLUS 1
BLT AC5,-1(AC4) ;BLAT!!
JUMPLE AC11,WRTR22 ;IF NO MORE TO DO, QUIT
MOVSI AC5,(AC12) ;NEW 'FROM' ADDRESS
PUSHJ PP,WRTBUF ;WRITE OUT THE BUFFER
JRST WRTR21 ;LOOP FOR NEXT PIECE OF RECORD
WRTR22: MOVE AC2,D.RCL(I16) ;[343] IF THIS IS THE LAST RECORD
CAIN AC2,1 ;[343] IN THIS LOGICAL BLOCK
SETZM D.OBC(I16) ;[343] NOTE THAT THE BUFFER IS FULL
JRST WRTRE7 ;GO HOME
; HERE TO WRITE OUT AN EBCDIC FILE
WER: MOVE AC10,D.WCNV(I16) ; GET CONVERSION INSTRUCTION
LDB AC3,WOPRS. ; GET RECORD SIZE
SKIPL D.F1(I16) ; VARIABLE LENGTH RECORDS?
JRST WEF1 ; NO - FIXED LENGTH
;WILL THE RECORD FIT IN THE CURRENT LOGICAL BLOCK?
LDB AC1,F.BBKF ; ONLY BLOCKED FILES HAVE A BDW
JUMPE AC1,WEV3 ; JUMP IF UNBLOCKED FILE
MOVE AC1,D.FCPL(I16) ; GET NUMBER OF FREE BYTES LEFT
CAIGE AC1,4(AC3) ; WILL IT FIT?
PUSHJ PP,WELB ; NO - WRITE LAST BUFFER
CAME AC1,D.TCPL(I16) ; IS THIS FIRST RECORD IN LOG-BLK?
TDZA C,C ; NO
SETO C, ; YES
SUBI AC1,4(AC3) ; UPDATE THE CHAR-COUNT
MOVEM AC1,D.FCPL(I16) ; FREE CHARS PER LOG-BLOCK
;UPDATE THE BLOCK-DESCRIPTOR-WORD (BDW)
TXNN AC13,DV.MTA ; SKIP IF A MTA
JRST WEV2 ; JUMP IF NOT
HRRZ AC1,D.OBH(I16) ; POINTS TO CURRENT BUFFER
HRLZI AC2,4(AC3) ; GET THE RECORD SIZE + RDW
JUMPE C,WEV1 ; JUMP IF NOT FIRST RECORD
HRLZI AC2,4+4(AC3) ; REC-SIZE +4 FOR RDW +4 FOR BDW
MOVNI AC0,4 ; UPDATE THE BYTE-COUNT
ADDM AC0,D.OBC(I16) ; YES - DOIT
AOSA AC5,D.OBB(I16) ; UPDATE THE BYTE POINTER
WEV1: MOVE AC5,D.OBB(I16) ; DO WE HAVE 8 OR 9 BIT BYTES?
TLNN AC5,000100 ; IF 8 BIT BYTES
LSH AC2,2 ; MOVE BDW OVER 2 BITS
ADDM AC2,2(AC1) ; ADD THIS RECORD SIZE TO BDW
JRST WEV3 ;
WEV2: JUMPE C,WEV3 ; JUMP IF NOT FIRST REC IN BLOCK
HRRZ C,D.TCPL(I16) ; GET TOTAL CHARS PER LOG-BLK
HRRZI C,4(C) ; PLUS 4 FOR BDW
PUSHJ PP,WEDW ; MAKE A BDW
;POINT AC5 AT RECORD-DESCRIPTOR-WORD (RDW)
; PUT THE RDW INTO THE BUFFER
WEV3: MOVEI C,4(AC3) ; GET REC-SIZE TO C
PUSHJ PP,WEDW ; GO MAKE A RDW
MOVE AC5,D.OBB(I16) ; GET BYTE POINTER
;NOW MOVE THE RECORD TO THE BUFFER
WEV4: SOSGE D.OBC(I16) ; BUFFER FULL?
PUSHJ PP,WEBF ; YES
ILDB C,AC6 ; GET CHAR FROM RECORD AREA
XCT AC10 ; CONVERT IF NECESSARY
IDPB C,AC5 ; PUT IN BUFFER
SOJG AC3,WEV4 ; LOOP TIL DONE
MOVEM AC5,D.OBB(I16) ; RESTORE BYTE POINTER
JRST WRTR10 ; DONE
; MOVE FIXED LENGTH RECORD TO BUFFER
WEF1: TLNE FLG1,MSTNDR ; LABELED TAPE?
PUSHJ PP,PADLAB ; YES,GO SET FOR PADDING
WEF1A: ILDB C,AC6 ; GET CHAR FROM RECORD AREA
XCT AC10 ; CONVERT IF NECESSARY
IDPB C,D.OBB(I16) ; PUT IN BUFFER
SOSG D.OBC(I16) ; BUFFER FULL?
PUSHJ PP,WRTBUF ; YES
SOJG AC3,WEF1A ; LOOP TIL DONE
TLNE FLG1,MSTNDR ; WAS THAT LABELED TAPE?
PUSHJ PP,LABPAD ; YES, DO ANY PADDING INDICATED BY STACK
JRST WRTRE7 ; DONE
; THE CURRENT RECORD WONT FIT SO FINISH OFF THIS LOGICAL BLOCK
WELB: PUSHJ PP,WRTOUT ; DUMP THE BUFFER
SOSLE D.BCL(I16) ; ANY EMPTY BUFFERS TO GO OUT?
JRST WELB ; YES
MOVE AC1,D.BPL(I16) ; GET BUFFERS PER LOG-BLOCK
MOVEM AC1,D.BCL(I16) ; BUFFERS PER CURRENT LOG-BLOCK
MOVE AC1,D.TCPL(I16) ; TOTAL CHARS PER LOG-BLOCK
MOVEM AC1,D.FCPL(I16) ; FREE CHARS PER LOG-BLOCK
POPJ PP, ;
; WRITE OUT THE CURRENT BUFFER
WEBF: MOVEM AC5,D.OBB(I16) ; RESTORE THE BYTE-PTR
WEBF1: PUSHJ PP,WRTOUT ; WRITE IT
MOVE AC5,D.OBB(I16) ; GET BYTE-PTR
SOS D.BCL(I16) ; DECREMENT BUFFERS PER CURRENT LOG-BLOCK
SOS D.OBC(I16) ; DECREMENT CHAR-COUNT
POPJ PP, ;
;WRITE A DESCRIPTOR WORD, BDW OR RDW
WEDW: LDB AC2,[POINT 6,D.OBB(I16),11] ; GET THE BYTE SIZE
MOVN AC1,AC2 ; AC1 SHIFT RIGHT - AC2 .. LEFT
ROT C,(AC1) ; GET THE HI ORDER BITS
PUSHJ PP,WECH ; STOW IT
ROT C,(AC2) ; GET LO ORDER BITS
PUSHJ PP,WECH ; STOW IT
SETZ C, ; GET A NULL
PUSHJ PP,WECH ; STOW IT
;WRITE AN EBCDIC CHARACTER
WECH: SOSGE D.OBC(I16) ; BUFFER FULL?
PUSHJ PP,WEBF1 ; DUMP IT
IDPB C,D.OBB(I16) ; DUMP THE CHAR
POPJ PP, ; RETURN
;WRITE AND READ SETUP. ***POPJ***
WRTSUP: MOVE AC13,D.DC(I16) ;DEVICE CHARACTERISTICS
MOVE FLG,F.WFLG(I16) ;FLAGS,,RECORD LOCATION
HLLZ FLG1,D.F1(I16) ;MORE FLAGS
PUSHJ PP,SETCN. ;SET THE IO CHANNEL NUMBER
LDB AC3,F.BMRS ;FILE TABLE MAX REC SIZE
LDB AC6,[POINT 2,FLG,14] ; GET CORE DATA MODE
MOVE AC6,RBPTB1(AC6) ; GET BYTE-POINTER TO RECORD AREA
HRR AC6,FLG ; RECORD ADR
POPJ PP, ;
;LEFT HALF IS BYTE-PTR TO RECORD AREA
;RIGHT HALF IS CHARS PER WORD
RBPTBL: POINT 7,5(FLG) ; ASCII
POINT 9,4(FLG) ; EBCDIC
POINT 6,6(FLG) ; SIXBIT
;LEFT IS BYTE-PTR TO RECORD AREA
;RIGHT IS BYTES PER WORD IN RECORD KEY
RBPTB1: POINT 7, 6 ; ASCII SIXBIT
POINT 9, 4 ; EBCDIC EBCDIC
POINT 6, 5 ; SIXBIT ASCII
;SETUP THE CONVERSION INST IN AC10
WRTXCT: JUMPL FLG,WRTXC1 ;JUMP IF ASCII DEV
SKIPA AC10,[MOVS C,CHTAB(C)] ;ASCII TO SIXBIT
WRTXC1: MOVE AC10,[ADDI C,40] ;SIXBIT TO ASCII
TLNN FLG,CONNEC ;
HRLZI AC10,(TRN) ;ASCII TO ASCII
POPJ PP, ;
;ADVANCING IS DONE HERE. ***POPJ***
WRTADV: TLCE AC15,WDVBFR ;WRTADV OPERAND
POPJ PP, ; NOT THIS TIME, RETURN
TLNE AC15,WDVPOS ; POSITIONING?
JRST WAD1 ; YES
HRRZ AC4,AC15 ; GET CHAR CNT
TLNN AC15,WDVADR ; IS THIS REALLY AN ADR?
JRST WAD0X ; NO
CAIE AC4,-1 ; YES, IS THIS REALLY THE DEFAULT
; ADVANCING CASE????
JRST WAD0 ; NO
HRRZ AC4,D.RFLG(I16) ; GET STANDARD ASCII FLAG
TRNE AC4,SASCII ; SKIP IF NOT STANDARD ASCII
POPJ PP, ; IFSO, RETURN, DEFAULT STD-ASCII IS 0
MOVEI AC4,1 ; ELSE , DEFAULT IS ADVANCING 1
JRST WAD0Y ; THEN CONTINUE TO ADVANCE
WAD0: HRRZ AC4,(AC15) ; GET COUNT FROM ADDRESS
WAD0X:
WAD0Y: LDB C,WOPCN ; GET CHANNEL NUMBER
JUMPN C,WAD2 ;GIVE UP IF NOT JUST LINE FEED
SKIPE D.LCV(I16) ;DO WE HAVE LINAGE STUFF?
MOVEI C,5 ;YES, USE DC3 INSTEAD
JRST WAD2 ;
WAD1: MOVEI AC4,1 ; ASSUME ONE CHAR TO OUTPUT
LDB C,[POINT 7,(AC15),35] ;[500] ONLY TAKE NEEDED CHAR
CAIL C,"1" ; IS CHAR "1"
CAILE C,"8" ; THRU "8"
JRST .+3 ; NO
TRZ C,777770 ; CONVERT TO BINARY
JRST WAD2 ;
CAIN C,"+" ;
POPJ PP, ; "+" = NO POSITIONING
CAIN C,"0" ;
MOVEI AC4,2 ; "0" = TWO "LF"
CAIN C,"-" ;
MOVEI AC4,3 ; "-" = THREE "LF"
SETZ C, ; GET A "LF"
WAD2: TLNE FLG,RANFIL+IOFIL ;[622] SKIP IF NOT A DUMP MODE FILE
JRST WAD3 ;
SKIPE NOCR. ;[WADV] SKIP IF WRITE CR
JRST WAD22A ;[WADV] ELSE DON'T
PUSH PP,C ; SAVE WADV CHANNEL
PUSHJ PP,WRTCR ;[WADV] OK,WRITE ONE
POP PP,C ; RESTORE WADV CHANNEL
SETOM NOCR. ;[WADV] INDICATE IT WAS DONE
WAD22A: ;[WADV]
; IF ADVANCING 0, JUST WRITE CR
JUMPE AC4,RET.1 ; IF CNT = 0 JUST RETURN
SKIPN D.LCV(I16) ;LINAGE-COUNTER?
JRST WAD2C ;NO
CAIN C,1 ;YES, IS IT PAGE?
JRST WAD2P ;YES
PUSH PP,C
PUSH PP,AC4 ;NEED 2 ACS
ADDB AC4,D.LCV(I16) ;INCREMENT BY NO. OF LINES
HLRZ C,F.LPP(I16) ;GET LINES PER PAGE
CAIG AC4,(C) ;OVERFLOW?
JRST WAD2A ;NO
AOS -2(PP) ;GIVE SKIP RETURN
WAD2D: MOVEI AC4,1 ;YES
MOVEM AC4,D.LCV(I16) ; RESET IT TO 1
HRRZ AC4,F.LAB(I16) ;LINES AT BOTTOM?
JUMPE AC4,WAD2E ;NO
PUSHJ PP,WRTDC3 ;YES
SOJG AC4,.-1 ;LOOP
WAD2E: MOVE C,-1(PP)
MOVE AC4,0(PP) ;RESTORE ACCS, BUT LEAVE ON STACK
PUSHJ PP,WAD2C ;OUTPUT ADVANCING CHAR.
HRRZ AC4,F.LCI(I16) ;NEED TO INITIALIZE FOR NEXT PAGE
JUMPE AC4,WAD2F ;NO
PUSHJ PP,SAVAC. ;SAVE THE CURRENT ACCS
PUSHJ PP,(AC4) ;GO TO USER ROUTINE
PUSHJ PP,RSTAC. ;RESTORE STATE
WAD2F: HLRZ AC4,F.LAT(I16) ;LINES AT TOP?
JUMPE AC4,WAD2G ;NO
PUSHJ PP,WRTDC3 ;YES
SOJG AC4,.-1 ;LOOP
WAD2G: POP PP,AC4
POP PP,C
POPJ PP,
WAD2P: HLRZ AC4,F.LPP(I16) ;GET LINES PER PAGE
SUB AC4,D.LCV(I16) ;CURRENT COUNT
ADDI AC4,1 ;ONE FOR THIS ADVANCING
MOVEI C,5 ;DC3
PUSH PP,C
PUSH PP,AC4
JRST WAD2D ;OUTPUT SOME BLANK LINES + BOTTOM AND TOP OF PAGE
WAD2A: HRRZ C,F.WFA(I16) ;GET FOOTING LIMIT
JUMPE C,WAD2B ;NO LIMIT
CAIL AC4,(C) ;DID WE OVERFLOW INTO FOOTING?
AOS -2(PP) ;YES, GIVE ERROR RETURN (BUT DON'T RESET COUNT)
WAD2B: POP PP,AC4
POP PP,C
WAD2C: MOVE C,WADTBL(C) ; GET CHAR FROM TABLE
PUSHJ PP,WRTCH ;
SOJG AC4,.-1 ;
POPJ PP, ;
WAD3: SKIPE NOCR. ;[WADV] SKIP IF MUST START WITH CR
JRST WAD3A ;[WADV] ELSE GO ON
PUSH PP,C ; SAV WADV CHANNEL
PUSHJ PP,RANCR ;[WADV] WRITE ONE
POP PP,C ; RESTORE WADV CHANNEL
SETOM NOCR. ;[WADV] INDICATE IT WAS WRITTEN
WAD3A: ;[WADV]
MOVE C,WADTBL(C) ; GET CHAR FROM TABLE
IDPB C,AC5 ;AC5 BYTE-PTR. TO RANDOM BUFFER AREA
SOJG AC4,.-1 ;
POPJ PP, ;
; CHAR CHANNEL NUMBER
WADTBL: EXP $LF ; 8
EXP $FF ; 1
EXP $DLE ; 2
EXP $DC1 ; 3
EXP $DC2 ; 4
EXP $DC3 ; 5
EXP $DC4 ; 6
EXP $VT ; 7
WRTDC3: PUSHJ PP,WRTCR ;CR
MOVEI C,$DC3 ;DC3
JRST WRTCH ;WRITE AND RETURN
WRTCRLF:
PUSHJ PP,WRTCR ;CR-LF
WRTLF: SKIPA C,WADTBL ;"LF"
WRTCR: MOVEI C,$CR ;"CR"
;[R672] WRTCH: SOSL D.OBC(I16) ;[655]SKIP IF YOU CAN
;[R672] JRST WRTCH1 ;[655] OVER THE PUSHJ
;[R672] PUSHJ PP,WRTBUF ;[655]WRITE OUT THE BUFFER
;[R672] SOS D.OBC(I16) ;[655]ADJUST COUNT FOR THIS BYTE
;[R672] WRTCH1: IDPB C,D.OBB(I16) ;[655]BYTE IN A CHARACTER
;[R672] POPJ PP, ;[655]AND RETURN
WRTCH: IDPB C,D.OBB(I16) ;[672] TO THE BUFFER
SOSLE D.OBC(I16) ;[672] SKIP IF FULL
POPJ PP, ;[672] OR RETURN
WRTBUF: PUSHJ PP,WRTOUT
SOS D.BCL(I16) ;BUFFER PER LOGICAL BLOCK
POPJ PP,
;HERE TO PADD BUFFER WITH PADD CHARACTER
PADBUF: SKIPG D.OBC(I16) ;ALREADY FULL?
POPJ PP, ;YES
PUSH PP,C ;JUST TO BE SURE
LDB C,[F%PADD] ;GET CHAR
IDPB C,D.OBB(I16) ;STORE IN BUFFER
SOSLE D.OBC(I16) ;FULL YET?
JRST .-2 ;NO
POP PP,C ;YES
POPJ PP, ;RETURN
;SEE IF ZERO LEN RECORD IS LEGAL
WRTZRE: SKIPE NOCR. ;
JRST WRTRE2 ;A WAY TO GET ONLY PAPER-ADVANCING-CHARS
MOVEI AC0,FE%23 ;ERROR NUMBER
PUSHJ PP,IGCVR ;IGNORE ERROR?
JRST WRTRE6 ;YES
OUTSTR [ASCIZ /Zero length records are illegal.
/]
MOVE AC2,[BYTE (5)10,31,20,22,4]
JRST KILL
;BLT RECORD AREA TO THE BUFFER/S
WRTRB: HRLZ AC5,FLG ;RECORD AREA I.E. "FROM"
WRTRB1: MOVE AC11,AC3 ;SETUP FOR THE "UNTIL"
SUB AC3,D.OBC(I16) ;REC-SIZE MINUS BYTE-COUNT
JUMPGE AC3,WRTRB2 ;JUMP, USE ALL OF CURRENT BUFFER
MOVN AC3,AC11 ;SO WE CAN ADJ THE BYTE-COUNT
JRST WRTRB3 ;PROCEED
WRTRB2: MOVE AC11,D.OBC(I16) ;BYTE-COUNT
SETZM D.OBC(I16) ;ZERO THE BYTE COUNT
WRTRB3: IDIVI AC11,6 ;CONVERT TO WORDS
MOVE AC2,AC12 ;SAVE FOR ZERO FILL
JUMPE AC12,WRTRB4 ;CHECK THE REMAINDER
ADDI AC11,1 ;ADJ IF THERE WAS ONE
SUBI AC12,6 ;NEGATE TRAILING NULL BYTES
WRTRB4: SKIPE D.OBC(I16) ;SKIP IF BUFFER IS FULL
ADD AC12,AC3 ;ADD IN THE REC-SIZE
ADDM AC12,D.OBC(I16) ;SUBTRACT FROM THE BYTE-COUNT
HRR AC5,D.OBB(I16) ;"TO" ADDRESS
HRRZ AC4,AC5 ;
ADDI AC4,-1(AC11) ;"UNTIL" ADDRESS
HLRZ AC12,AC5 ;SAVE ORIGIN
ADDM AC12,AC11 ;NEXT ORIGIN
BLT AC5,(AC4) ;SHAZAM!
HRL AC5,AC11 ;NEXT "FROM" ADR
HRLI AC4,600 ;NO MORE BYTES THIS WORD
MOVEM AC4,D.OBB(I16) ;
SKIPLE D.OBC(I16) ;XIT IF U CAN
JRST WRTRB5 ;EXIT
PUSHJ PP,WRTBUF ;ADVANCE TO NEXT BUFFER
JUMPLE AC3,WRTRB5 ;EXIT IF DONE
PUSHJ PP,WRTABP ;ADJ THE BYTE-PTR
JRST WRTRB1 ;LOOP TILL ALL IS BLT'ED
WRTRB5: JUMPE AC2,WRTRE7 ;EXIT IF NO NO FILL REQUIRED
IMULI AC2,-6 ;ZERO FILL THE LAST WORD
SETO AC0, ;--
LSH AC0,(AC2) ;--
ANDCAM AC0,(AC4) ;DOIT
JRST WRTRE7 ;EXIT
;ADJUST THE BYTE-POINTER TO POINT TO NON-EX BYTE LEFT OF NEXT WORD
WRTABP: SKIPGE AC1,D.OBB(I16) ;
POPJ PP, ;
TLZ AC1,770000 ;
ADD AC1,[POINT ,1] ;
MOVEM AC1,D.OBB(I16) ;
POPJ PP, ;
ERROP3: AOS (PP) ;WRITE ERROR IMPROPER OPEN MODE
MOVEI AC0,FS%30 ;IS PERMANENT ERROR
MOVE AC1,D.RFLG(I16) ;GET OPEN EXT FLAG
TXNN AC1,EXTOPN ; FILE OPENED FOR EXTEND?
TXNE FLG,OPNOUT ; OPENED FOR OUTPUT?
TRNA ; YES TO ONE OR THE OTHER
SKIPL WANT8. ;WANT 8x FUNCT?
JRST ERROP4 ; NO
MOVEI AC0,FS%48 ;YES, SET PROPER FILE-STATUS
MOVEM AC0,FS.FS ; AND SAVE FOR REPORTING
ERROP4: MOVEI AC0,FE%22 ;THE "OUTPUT" MESSAGE
JRST ERROP2
ERROPN: AOS (PP) ;REWRITE-DELETE ERROR IMPROPER OPEN MODE
; ALSO, WRITE "DUPL KEY VIOL" C-74
TXNN AC16,V%RWRT!V%DLT ;REWRITE OR DELETE?
JRST ERROP4 ; NO
MOVEI AC0,FS%30 ;IS PERMANENT ERROR
TXNE FLG,OPNIO ; OPENED FOR IO?
TRNA ; YES
SKIPL WANT8. ;WANT 8x FUNCT?
JRST ERROP4 ;NO,
MOVEI AC0,FS%49 ;yes, SET I-O FILE-STATUS
MOVEM AC0,FS.FS ; AND SAVE FOR REPORTING
JRST ERROP4
ERROP1: MOVEI AC0,FS%47
SKIPGE WANT8. ;WANT 8x FUNCT?
MOVEM AC0,FS.FS ;YES, SAVE IT FOR REPORTING
MOVEI AC0,FE%34 ;THE "INPUT" MESS
ERROP2: SETOM FS.IF ;IDX FILE
TLNE FLG,IDXFIL ;ISAM FILE?
ADD AC0,[E.FIDX] ;YES
SETZ AC2,
PUSHJ PP,IGCVR ;IGNORE ERROR?
POPJ PP, ;YES, TAKE A NORMAL EXIT
MOVE AC2,[BYTE (5)10,31,20,6,14]
PUSHJ PP,MSOUT. ;"FILE IS NOT OPEN"
HRLZI AC2,(BYTE (5)7) ;"FOR INPUT"
TXNN AC16,V%READ ;SKIP IF ATTEMPT TO READ
HRLZI AC2,(BYTE (5)11);"FOR OUTPUT"
TXNN AC16,V%RWRT!V%DLT ;FOR "REWRITE" OR "DELETE"?
JRST ERDLR1 ;NO
OUTSTR [ASCIZ/ for Input-Output./]
SETZ AC2, ;GO TO KILL
ERDLR1: PUSHJ PP,MSOUT. ;NEVER RETURNS
ERRMR0: SKIPA AC3,AC0 ;ISAM FILE
ERRMR1: MOVE AC2,AC0 ;IO OR RANDOM FILE
TRNA
ERRMR2: EXCH AC3,AC4 ;SEQUENTIAL FILE
PUSH PP,AC0 ;SAVE MAX-REC-SIZE
SKIPL WANT8. ;WANT 8x FUNCT?
JRST ERRMR3 ;NO
MOVEI AC0,FS%04 ;WRONG-LENGTH RECORD FOR READ
TXNE AC16,V%RWRT!V%WRIT!V%WADV ;DOING WRITE OR REWRITE?
MOVEI AC0,FS%44 ; YES, SOCK IT TO EM!
MOVEM AC0,FS.FS ;AND SAVE IT ASIDE
ERRMR3: MOVEI AC0,FE%6 ;THE ERROR NUMBER
TLNE FLG,IDXFIL ;ISAM FILE?
ADD AC0,[E.FIDA] ;YES
PUSHJ PP,IGCVR ;IGNORE ERROR?
JRST ERRMRX ;YES
ERRMRS: PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /The maximum record size may not be exceeded./]
ERRMR: TXNE AC16,V%READ ;SKIP IF OUTPUT FILE
SKIPA AC2,[BYTE (5)10,31,20,21,4]
MOVE AC2,[BYTE (5)10,31,20,22,4]
PUSHJ PP,MSOUT. ;CANNOT DO OUTPUT (OR INPUT)
ERRMRX: POP PP,AC0 ;RESTORE MAX-REC-SIZE
POPJ PP,
ERRLR2: PUSH PP,AC0 ;SAVE MAX-REC-SIZE
TLNE FLG,IDXFIL ;ISAM FILE?
SKIPL WANT8. ;WANT 8x FUNCT?
JRST ERRRL3 ;NO
MOVEI AC0,FS%04 ;WRONG-LENGTH RECORD FOR READ
TXNE AC16,V%RWRT!V%WRIT!V%WADV ;DOING WRITE OR REWRITE?
MOVEI AC0,FS%44 ; YES, SOCK IT TO EM!
MOVEM AC0,FS.FS ;AND SAVE IT ASIDE
ERRRL3: MOVEI AC0,FE%6 ;THE ERROR NUMBER
ADD AC0,[E.FIDA] ;YES
PUSHJ PP,IGCVR ;IGNORE ERROR?
JRST ERRMRX ;YES
PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /The minimum record size may not be exceeded./]
JRST ERRMR
SUBTTL READ VERB
;A READ VERB LOOKS LIKE:
;FLAGS,,ADR WHERE ADR = FILE TABLE ADDRESS
;CALL+1: NORMAL RETURN
;CALL+2: "AT-END" OR "INVALID-KEY" RETURN
RDNXT.: TXO AC16,V%RNXT ;TURN ON READ NEXT FLAG
READ.: SKIPE F.WSMU(I16) ;ANY RETAINED RECORDS?
PUSHJ PP,SU.RD ; YES
MOVEI AC0,RDLAST ;TURN OFF VALID READ FLAG
ANDCAM AC0,D.RFLG(I16) ;ONLY TURN ON IF SUCCESSFUL
IFN ISTKS,<JRST FAKER1>
FAKER.:
IFN ISTKS,<HLRZ I12,D.BL(I16)
AOS OUTSSS+15(I12)
FAKER1:>
TXO AC16,V%READ ; ENTRY POINT FOR FAKE READ
HLRZ AC12,D.BL(I16)
MOVE AC0,[FS.ZRO,,FS.FS];ZERO THE ERROR
BLT AC0,FS.IF ; STATUS WORDS.
PUSHJ PP,WRTSUP ;SETUP
SKIPGE WANT8. ;WANT 8x FUNCT?
TXNN AC16,V%RNXT ;YES, DOING READ NEXT?
JRST FAKER2 ; NO
MOVE AC0,D.RFLG(I16) ;GET EXTRA FLAGS
TXNN AC0,B%BDRD ;BAD READ PRECEDES?
JRST FAKER2 ;NO
MOVEI AC0,FS%46 ;SET UP READ SEQ AFTER BAD READ F-S CODE
MOVEM AC0,FS.FS ; AND SAVE IT ASIDE
MOVEI AC0,FE%60 ;ERROR NUMBER
PUSHJ PP,IGCVR ;SET UP FILE-STATUS
JRST KILL ; MAKE FATAL IF ERROR RETURN
FAKER2: MOVX AC0,B%BDRD ;CLEAR BAD-READ FLAG
ANDCAM AC0,D.RFLG(I16) ; IN FILE-TABLE ENTRY
TLNE FLG,NOTPRS ;JUMP IF OPTIONAL AND NOT PRESENT
JRST RERE7 ;
TLNN FLG,OPNIN ;SKIP IF OPEN FOR INPUT
JRST ERROP1 ;
TLNE FLG,ATEND ;SKIP IF NOT "AT END"
JRST REAAEE ;"FILENM IS AT END" STOPR.
MOVE AC10,D.RCNV(I16);SETUP AC10
TLNE FLG,IDXFIL ;INDEX FILE?
JRST IREAD ;YES
TLNE FLG,RANFIL+IOFIL ;[622] SKIP IF NOT RANDOM OR I/O
JRST RANDOM ;RANDOM AND IO EXIT HERE
TLNE FLG,DDMEBC ;EBCDIC?
JRST RER ; USE EBCDIC ROUTINE
JUMPL FLG,READ4 ;JUMP IT'S ASCII
TLNE FLG,DDMBIN ;IF BINARY,
JRST READ10 ; USE THIS ROUTINE
;PICKUP REC-SIZE (FIRST WORD) AND CHECK AGAINST MAX-REC-SIZE.
MOVE AC4,D.IBC(I16) ;INPUT BYTE COUNT
CAILE AC4,1 ;SKIP IF THE BUFFER IS EMPTY
JRST READ3 ;
READ2: PUSHJ PP,READBF ; FILL IT.
TLNE FLG,CONNEC ;SKIP IF WE'RE BLT'ING THE RECORD
AOS D.IBC(I16) ;SO THE BYTE COUNT WILL BE RIGHT
READ21: LDB AC3,F.BMRS ;RESTORE AC3
TLNE FLG,ATEND ;CHECK FOR END-OF-FILE
JRST READEF ;TAKE A SKIP EXIT TO THE "ACP"
READ3: PUSHJ PP,REAABP ;ADJUST THE BYTE-POINTER
AOS D.IBB(I16) ;DONT OVERWRITE REC-SIZE
TXNN AC13,DV.MTA ;MTA?
JRST READ31 ;NO
HLRZ AC4,(AC1) ;GET RECORD SEQUENCE NUMBER
JUMPE AC4,READ31 ;JUMP IF NO RSN
HRRZ AC0,D.RP(I16) ;GET RECORD COUNT
CAME AC4,AC0 ;OK?
JRST REALR ;NO - LOST OR GAINED A RECORD
READ31: HRRZ AC4,(AC1) ;INCASE ITSA ASCII DATA WRD & NOT 6BIT CHR-CNT
JUMPE AC4,RED31B ;NO TESTS IF ZERO
CAML AC3,AC4 ;[613] SKIP IF MAX RECORD SIZE IS EXCEEDED
JRST RED31A ;[613] ELSE OK, CONTINUE
PUSHJ PP,ERRMR2 ;ERROR MESSAGE
;[613] PRINT WARNING THAT RECORD LENGTH FIELD (SIXBIT OR V FORMAT)
;[613] IS LARGER THAN FD MAXIMUM
OUTSTR [ASCIZ/%Record length field larger than FD maximum, assuming max.
/]
; AC4 LOADED WITH MAX SIZE IN ERRMR2
RED31A: LDB AC3,F.BLRS ;LOAD MINIMUM SIZE
CAMG AC3,AC4 ;IS RECORD LESS THAN MINIMUM
JRST RED31B ;NO
PUSHJ PP,ERRLR2 ;ERROR MESSAGE
;PRINT WARNING THAT RECORD LENGTH FIELD (SIXBIT OR V FORMAT)
;IS SMALLER THAN FD MINIMUM
OUTSTR [ASCIZ/%Record length field smaller than FD minimum.
/]
RED31B: MOVEM AC4,RELEN. ;[613] [332] FOR STAND ALONE SORT
MOVEM AC4,D.CLRR(I16) ;[545] SAVE THE CHARACTER COUNT
HRRZ AC3,AC4 ;MOVE IT INTO AC3
MOVN AC4,D.BPW(I16) ;CPW
ADDB AC4,D.IBC(I16) ;SUB FROM THE BYTE COUNT
JUMPE AC3,READ32 ;ZERO LENGTH RECORD
TLNE FLG,CONNEC ;SKIP IF CONVERSION IS NOT NECESSARY
JRST READ4 ;NEED TO CONVERT
JUMPN AC4,REABR ;GO BLT
PUSHJ PP,READBF ;ADVANCE THE BUFFER FIRST
PUSHJ PP,REAABP ;ADJ THE BYTE-PTR
TLNN FLG,ATEND ;CHECK FOR EOF
JRST REABR ;THEN GO BLT
JRST REAAE1 ;ERROR MESSAGE
;HERE TO READ AHEAD TO FIND NEXT NON-0-LENGTH RECORD
;IF NOT FOUND TAKE THE ATEND PATH
READ32: LDB AC4,F.BBKF ;SKIP THE FOLLOWING TEST IF
JUMPE AC4,READ34 ; BLOCKING-FACTOR IS ZERO
SOSE D.RCL(I16) ; OR IF THERE ARE MORE RECORDS IN
JRST READ34 ; THIS LOGICAL-BLOCK
MOVEM AC4,D.RCL(I16) ;RESTORE # OF RECORDS IN CURRENT LOGICAL-BLOCK
SKIPLE AC4,D.BCL(I16) ;IGNORE ANY TRAILING BUFFERS IN THIS
READ33: PUSHJ PP,READBF ; LOGICAL-BLOCK
SETZM D.IBC(I16) ;DECLARE HIS BUFFER EMPTY
TLZN FLG,ATEND ;LET THE NEXT RECORD GET THE "EOF"
SOJG AC4,READ33 ;PASS ALL OF THIS LOGICAL-BLOCK
MOVE AC4,D.BPL(I16) ;RESTORE THE POINTERS
MOVEM AC4,D.BCL(I16) ; BUFFERS PER CURRENT LOGICAL-BLOCK
READ34: MOVE AC4,D.IBC(I16) ;IF THE
CAILE AC4,1 ; BUFFER
JRST READ35 ; IS EMPTY
PUSHJ PP,READBF ; FILL IT.
TLNE FLG,CONNEC ;MAKE THE BYTE-COUNT RIGHT IF
AOS D.IBC(I16) ; RECORD IS TO BE BLT'ED
TLNE FLG,ATEND ;EOF MEANS TAKE
JRST READEF ; ATEND PATH
READ35: PUSHJ PP,REAABP ;ADJUST THE BYTE-POINTER
HRRZ AC3,(AC1) ;GET THE RECORD SIZE
JUMPN AC3,READ21 ;EXIT HERE IF N0N-0-LENGTH RECORD
AOS D.IBB(I16) ;ACCOUNT FOR THE
MOVN AC4,D.BPW(I16) ; HEADER
ADDM AC4,D.IBC(I16) ; WORD
JRST READ32 ;LOOP TIL EOF OR N0N-0-LENGTH RECORD
;PASS LEADING "EOL" CHARACTERS.
READ4: SETZ AC5, ; [577] CLEAR AC5, INDICATING NOT MTA EOR
READ4A: SOSG D.IBC(I16) ; SKIP IF CHAR IN BUFFER
PUSHJ PP,READBF ; ELSE GET ANOTHER BUFFER
TLNE FLG,ATEND ;SKIP IF NOT "EOF"
JRST READEF ;"AT-END" BUT DONT INC REC COUNT
ILDB C,D.IBB(I16) ; GET THE CHAR
IFN BLANKL, <
CAIN C,15 ;[1126] Is it a carriage return?
JRST READ5A ;[1126] Yes, make a blank record
>; [1126]
XCT AC10 ;CONVERT IF NECESSARY
IFE SIRUS, < JUMPLE C,READ4A ;JUMP IF EOL CHAR OR NULL>
MOVE AC5,AC3 ;SAVE ACTUAL RECORD SIZE FOR ZERO FILL
MOVEM AC5,RELEN. ;[332] INITIAL RELEASE SIZE
MOVEM AC5,D.CLRR(I16) ;[545] SAVE THE CHARACTER COUNT INCASE TOO BIG
IFN SIRUS,< JUMPL C,READ5A ; [403] EMPTY RECORD-TREAT AS ALL BLANKS >
;LOAD THE RECORD AREA FROM THE BUFFER.
READ5: IDPB C,AC6 ;
SOJE AC3,READ51 ;DECREMENT REC SIZE
PUSHJ PP,READCH ;
TLNE FLG,ATEND ;SKIP IF NOT "EOF"
JRST REAAE1 ;MESS AND KILL
XCT AC10 ;CONVERT IF NECESSARY
JUMPGE C,READ5 ;JUMP IF NON EOL CHAR
READ5A: EXCH AC5,RELEN. ;[332]CORRECT RELEASE SIZE
SUBI AC5,(AC3) ;[332]
MOVEM AC5,D.CLRR(I16) ;[545] SAVE THE CHARACTER COUNT
EXCH AC5,RELEN. ;[332]
IFN SIRUS,<
PUSHJ PP,READ52 ; [403] FILL OUT REST OF REC WITH SPACES
JRST READ8 ; [403] FINISHED
>
READ52: MOVEI C," " ;ASCII SPACE
TLNE FLG,CDMSIX ; [640] SIXBIT?
SETZ C, ; [640] SIXBIT SPACE
TLNE FLG,CDMEBC ; [640]EBCDIC?
MOVEI C,100 ; [640]EBCDIC SPACE
IDPB C,AC6 ;TRAILING SPACES
SOJG AC3,.-1 ;FILL OUT THE RECORD WITH SPACES
IFE SIRUS,< JRST READ8 ; [403] >
IFN SIRUS,< POPJ PP, ; [403] FINISHED >
READ51: LDB AC3,F.BMRS ;GET MAX RECORD SIZE
SUB AC3,AC5 ;NUMBER OF ZEROS TO FILL
IFE SIRUS,< JUMPG AC3,READ52 ;DOIT >
IFN SIRUS,< JUMPLE AC3,READ6 ; [403] GO LOOK FOR EOL
PUSHJ PP,READ52 ; [403] FILL BLANKS
>
;RECORD IS FULL. PASS CHAR TILL AN "EOL" CHAR IS ENCOUNTERED.
READ6: JUMPGE FLG,READ7 ;JUMP SIXBIT HAS NO "EOL"
HRRZ AC0,D.RFLG(I16) ; GET STANDARD ASCII FLAG
TRNE AC0,SASCII ; SKIP IF NOT STANDARD ASCII
JRST READ8 ; ELSE CONT, ASSUME NO CR-LF FOR
; STD-ASCII
LDB AC0,F.BBKF ; GET BLOCKING FACTOR
JUMPE AC0,READ6A ; JUMP IF NOT A BLOCKED FILE
MOVE AC0,D.RCL(I16) ; GET THE RECS LEFT IN LOG-BLK
SOJLE AC0,READ8 ; AND QUIT IF THIS IS LAST
READ6A: SOSG D.IBC(I16) ; DECREMENT BYTE COUNT,SKIP IF BUFFER EMPTY
PUSHJ PP,READBF ;BL; GET ANOTHER BUFFER
TLZE FLG,ATEND ;BL;EOF?
JRST READ8A ; CHECK OUT
ILDB C,D.IBB(I16) ; RETURN A CHAR IN C
JUMPE C,READ6A ; SKIP NULL
XCT AC10 ; CONVERT IF INDICATED
JUMPL C,READ7 ; END SCAN & CHECK END OF WORD
JRST READ6A ; ELSE CONT SCAN FOR EOR CHAR
;BL THIS IS TO COUNT UNUSED SIXBIT-BYTES AT END OF RECORD
READ7: JUMPL FLG,READ8 ;JUMP IF ASCII DEV
READ7A: MOVE AC1,D.IBB(I16) ;INPUT BYTE POINTER
TLNN AC1,770000 ;ANY BYTES LEFT?
JRST READ8 ; NO
IBP D.IBB(I16) ; YES, STEP ALONG
SOS D.IBC(I16) ; & COUNT DOWN
JRST READ7A ; RETRY
; HERE IF GOT EOF WHEN SCANNING AHEAD FOR EOR
READ8A: TXNE AC13,DV.MTA ; MTA?
XCT MBSPR. ; YES, BACK UP SO ANOTHER READ WILL GET IT
READ8: PUSHJ PP,WRTRE7 ;UPDATE DEVTAB, RERUN DUMP, ETC
TRN ;
MOVE AC1,RELEN. ;[332] CONVERT RELEN. TO WRDS
MOVEI AC3,6 ;[332] FOR SIXBIT
TLNE FLG,CDMASC ; [406] UNLESS INTERNAL RECORD IS ASCII.
MOVEI AC3,5 ;[322] USE 5 CHARS/WD
ADDI AC1,-1(AC3) ;[322] FOR ROUNDING
IDIVI AC1,(AC3) ;[332]
MOVEM AC1,RELEN. ;[332] PUT IT AWAY
MOVEM FLG,F.WFLG(I16) ;
POPJ PP, ; EXIT TO THE ***"ACP"***
;READ A BINARY RECORD
READ10: SKIPLE AC4,D.IBC(I16) ;IF BUFFER NOT EMPTY
JRST READ11 ; DON'T NEED ANOTHER
PUSHJ PP,READBF ;GET ANOTHER BUFFER FULL
TLNE FLG,ATEND ;IF NO MORE,
JRST READEF ; WE ARE AT END
READ11: LDB AC11,F.BMRS ;GET RECORD SIZE IN BYTES
MOVEM AC11,D.CLRR(I16) ;SAVE LENGTH OF REC READ
MOVEI AC12,6 ;ASSUME DATA RECORD IS SIXBIT
TLNE FLG,CDMASC ;IS IT ACTUALLY ASCII?
MOVEI AC12,5 ;YES--5 BYTES PER WORD
TLNE FLG,CDMEBC ;[555] IS IT EBCDIC?
MOVEI AC12,4 ;[555] YES--4 BYTES PER WORD
ADDI AC11,-1(AC12) ;CONVERT TO
IDIVI AC11,(AC12) ; WORDS AND ROUND UP
HRR AC5,FLG ;DESTINATION IS RECORD AREA
READ12: MOVE AC4,D.IBB(I16) ;MOVING FROM BUFFER WORD
HRLI AC5,1(AC4) ; PLUS 1
MOVE AC4,AC11 ;IF SIZE IS
CAMLE AC4,D.IBC(I16) ; MORE THAN THAT LEFT IN BUFFER,
MOVE AC4,D.IBC(I16) ; USE ALL WORDS IN BUFFER
ADDM AC4,D.IBB(I16) ;BUMP BUFFER WORD ADDRESS
MOVN AC12,AC4 ;DECREMENT
ADDM AC12,D.IBC(I16) ; BUFFER COUNT
ADD AC11,AC12 ; AND WORDS LEFT IN RECORD
ADDI AC4,(AC5) ;COMPUTE FINAL DESTINATION PLUS 1
BLT AC5,-1(AC4) ;BLAT!!
JUMPLE AC11,READ8 ;IF ENTIRE RECORD MOVED, WE'RE DONE
MOVEI AC5,(AC4) ;NEW DESTINATION ADDRESS
PUSHJ PP,READBF ;GET ANOTHER BUFFER FULL
TLZN FLG,ATEND ;IF NOT AT END,
JRST READ12 ; LOOP
SETZM D.IBC(I16) ;FORCE READ NEXT TIME
READ13: SETZM (AC5) ;FILL
SOJLE AC11,READ8 ; REST OF RECORD
AOJA AC5,READ13 ; WITH ZEROES
;READ AN EBCDIC RECORD
RER: MOVE AC4,AC3 ; GET REC-SIZE FOR FIXED LEN-RECS
HLLZ FLG1,D.F1(I16) ; GET THE B%VLER FLAG
; IF EBCDIC LABELED, NON-"U" FORMAT, GET A BUFFER FULL
; IN THIS CASE EACH INPUT WILL GET ON LOG-RECORD
IFN TOPS20,<
TLNN FLG1,MSTNDR ; SKIP IF SYS-LABELED
JRST RER01 ; ELSE CONT
LDB AC1,F.BLBU ; GET FORMAT FLAG BIT
JUMPN AC1,RER01 ; IF "U" THEN CONT
; HERE IF EBCDIC NON=U FORMAT SYSTEM-LABELED TAPE
PUSHJ PP,RER20 ; DO AN INPUT, SHOULD READ ONE RECORD
JRST READEF ; EOF RETURN
JUMPGE FLG1,RER7 ; JUMP IF FIXED FORMAT
MOVE AC4,D.IBC(I16) ; FOR VAR-LEN RESET REC SIZE TO BE INPUT SIZE
JRST RER6 ; CHECK REC LENGTH AND CONT
>;END IFN TOPS20
RER01: LDB AC1,F.BBKF ; GET THE BLOCKING FACTOR
JUMPL FLG1,RER1 ; JUMP IF VARIABLE LEN-RECS
JUMPE AC1,RER7 ; JUMP IF UNBLOCKED FIXED-LEN-RECS
SOS AC1,D.RCL(I16) ; ANY MORE FIXED-LEN-RECS IN THIS BLOCK?
JUMPGE AC1,RER7 ; JUMP IF THERE ARE
PUSHJ PP,RER2 ; GET ANOTHER LOG-BLK
JRST READEF ; EOF RETURN
JRST RER7 ; AND CONT
RER1: JUMPE AC1,RER3 ; JUMP IF UNBLOCKED - NO BDW
SKIPLE AC1,D.FCPL(I16) ; ANY RECORDS IN THIS LOG-BLOCK?
JRST RER3 ; COULD BE, GO SEE
RER10: PUSHJ PP,RER2 ; NO, GET ANOTHER LOG-BLK
JRST READEF ; EOF RETURN
;NOW GET THE BLOCK-DESCRIPTOR-WORD
PUSHJ PP,REDW ; GET A BDW
JRST READEF ; EOF RETURN
SUBI AC4,4 ; IS LOGIGAL-BLOCK EMPTY?
JUMPLE AC4,RERE1 ; YES - ERROR
MOVEM AC4,D.FCPL(I16) ; AND SAVE IT AWAY
;NOW GET THE RECORD DESCRIPTOR WORD
RER3: PUSHJ PP,REDW ; GET A RDW
JRST READEF ; EOF RETURN
SUBI AC4,4 ; SUBTRACT OUT 4 FOR RDW
;NOW SEE IF WE GOT A LEGAL RECORD
LDB AC1,F.BBKF ; IF BLOCKING-FACTOR IS 0,
JUMPN AC1,RER5 ; JUMP IF A BLOCKED FILE
;FILE IS UNBLOCKED
JUMPG AC4,RER6 ; GET RECORD IF SIZE GT 0
PUSHJ PP,READBF ; NO RECORD - MUST BE EOF
TLNN FLG,ATEND ; IS IT?
JRST RERE2 ; NO! - SO ERROR
JRST READEF ; YES - TAKE ATEND PATH
; RER2 ROUTINE TO GET NEXT LOG-BLK FOR EBCDIC SEQ FILE
;
; RETURNS +1 IF EOF ENCOUNTERED
; +2 IF OK, NEW LOG-BLK READ
;PASS OVER CURRENT LOGICAL BLOCK AND GET NEXT
RER2: SKIPLE AC1,D.BCL(I16) ; ANY BUFFERS LEFT FOR THIS LOG-BLOCK?
RER21: PUSHJ PP,READBF ; PASS OVER THE EMTPY BUFFERS
TLNE FLG,ATEND ; END-OF-FILE?
POPJ PP, ; EOF,RETURN
SOJG AC1,RER21 ; GET THEM ALL
MOVE AC1,D.BPL(I16) ; BUFFERS PER LOG-BLOCK
MOVEM AC1,D.BCL(I16) ; BUFFERS PER CURRENT LOG-BLOCK
RER20: PUSHJ PP,READBF ; NOW GET THE NEXT RECORD
TLNE FLG,ATEND ; END-OF-FILE?
POPJ PP, ; EOF,RETURN
LDB AC1,F.BBKF ; GET BLOCKING FACTOR
SUBI AC1,1 ; DECREMENT IT FOR THE CURRENT RECORD
MOVEM AC1,D.RCL(I16) ; SAVE AS RECORDS/LOG-BLOCK
MOVE AC5,D.IBB(I16) ; SET BYTE-PTR TO AC5
JRST RET.2 ; OK, SKIP RETURN
;FILE IS BLOCKED
RER5: JUMPLE AC4,RER10 ; IF LOG-BLOCK IS EMPTY GET NEXT ONE
MOVNI AC0,4(AC4) ; SUBTRACT RDW FROM
ADDB AC0,D.FCPL(I16) ; "FREE CHARS PER LOGICAL-BLOCK"
JUMPL AC0,RERE3 ; ERROR IF REC GT SIZE OF LOG-BLOCK
RER6: JUMPE AC4,RER7A ;NO TESTS IF ZERO
CAMG AC4,AC3 ;[613] WILL IT FIT IN RECORD AREA?
JRST RER7 ;[613] YES, CONTINUE
PUSHJ PP,ERRMR2 ; NO - COMPLAIN
;[613] PRINT WARNING THAT RECORD LENGTH FIELD (SIXBIT OR V FORMAT)
;[613] IS LARGER THAN FD MAXIMUM
OUTSTR [ASCIZ/%Record length field larger than FD maximum, assuming max.
/]
; AC4 LOADED WITH MAX SIZE IN ERRMR2
RER7: LDB AC3,F.BLRS ;LOAD MINIMUM SIZE
CAMG AC3,AC4 ;IS RECORD LESS THAN MINIMUM
JRST RER7A ;NO
PUSHJ PP,ERRLR2 ;ERROR MESSAGE
;PRINT WARNING THAT RECORD LENGTH FIELD (SIXBIT OR V FORMAT)
;IS SMALLER THAN FD MINIMUM
OUTSTR [ASCIZ/%Record length field smaller than FD minimum.
/]
;MOVE THE RECORD INTO THE RECORD AREA
RER7A: SETZ AC0, ; CLEAR NULL CHAR COUNT
MOVEM AC4,D.CLRR(I16) ;[545] SAVE THE CHARACTER COUNT
RER71: SOSL D.IBC(I16) ; ANY CHARS AVAILABLE?
JRST RER74 ; YES
PUSH PP,AC0 ; [607] NO, SAVE NULL CHAR COUNT
PUSHJ PP,READBF ; GET ANOTHER BUFFER
IFN TOPS20,<
TLNN FLG1,MSTNDR ; IS TAPE SYS-LABELED?
JRST RER71A ; NO,JUMP
LDB AC1,F.BLBU ; GET FORMAT FLAG BIT
JUMPN AC1,RER71A ; JUMP IF "U"
MOVE AC4,D.IBC(I16) ; ELSE, RESET RECORD LENGTH
MOVEM AC4,D.CLRR(I16) ; HERE TOO
>;END IFN TOPS20
RER71A: POP PP,AC0 ; [607] RESTORE NULL CHAR COUNT
TLNN FLG,ATEND ; END-OF-FILE?
JRST RER73 ; NO
JUMPGE FLG1,READEF ; YEP - ITSA EOF
JRST RERE4 ; VAR-LEN-REC, COULD BE AN ERROR
RER73:
;[607] SETZ AC0, ; CLEAR NULL CHAR COUNT
SOS D.IBC(I16) ; DECREMENT THE BYTE-COUNT
RER74: ILDB C,D.IBB(I16) ;[435] GET CHAR
JUMPN C,RER75 ; EXIT IF NON-NULL
ADDI AC0,1 ; COUNT THE NULLS
SOJG AC4,RER71 ;[435] LOOP FOR A RECORD
;GOT A NULL RECORD
HRRZ AC4,D.RFLG(I16) ; GET SOME FLAGS
TXNN AC4,RDDREV ; READ REVERSE OPEN ACTIVE?
JRST RER74A ; NO CONT
SOS D.RP(I16) ; DECREMENT REC COUNT
JRST RER74B ; CONT
RER74A: AOS D.RP(I16) ; COUNT THE RECORD
RER74B: LDB AC4,F.BMRS ; RESTORE RECORD SIZE
JRST RER ; AND TRY FOR THE NEXT ONE
;GOT A NON-NULL CHAR SO RESTORE THE NULLS IF ANY
RER75: JUMPE AC0,RER82 ; EXIT HERE IF NO NULLS AT ALL
SETZ C, ; MAKE A NULL
XCT AC10 ; CONVERT IT
IDPB C,AC6 ; RESTORE IT
SOJG AC0,.-1 ; LOOP
LDB C,D.IBB(I16) ;[435] REGET THE LAST CHAR.
JRST RER82 ; OFF TO MAIN LOOP
RER8: SOSL D.IBC(I16) ; ANY CHARS LEFT?
JRST RER81 ; YES
PUSHJ PP,READBF ; NO - GET ANOTHER BUFFER
TLNE FLG,ATEND ; END-OF-FILE?
JRST RERE4 ; YEP - COULD BE AN ERROR
SOS D.IBC(I16) ; DECREMENT THE BYTE-COUNT
RER81: ILDB C,D.IBB(I16) ;[435] GET CHAR.
RER82: XCT AC10 ; CONVERT
IDPB C,AC6 ; PUT CHAR
SOJG AC4,RER8 ; LOOP
JRST WRTR10 ; GO HOME
;GET A CHARACTER
RECH: SOSL D.IBC(I16) ; [435] BUFFER EMPTY?
JRST RECH1 ; [435] NO.
PUSHJ PP,READBF ; [435] YES, GO FILL IT.
SOS D.IBC(I16) ; [435] KEEP THE CHAR COUNT RIGHT.
RECH1: ILDB C,D.IBB(I16) ; [435] GET CHAR
TLNN FLG,ATEND ; EOF?
AOSA (PP) ; NO - SKIP RETURN
SETZ C, ; YES - RETURN A NULL
POPJ PP, ;
;READ A DISCRIPTOR WORD, BDW OR RDW
REDW: MOVE AC4,D.IBC(I16) ; IF BYTE-COUNT LE 3 AND
CAILE AC4,3 ; THIS LAST BUFFER OF LOGICAL BLOCK
JRST REDW1 ; THEN THE BYTE-CNT MAY REALLY
LDB AC4,F.BBKF ; BE A ZERO. THE MONITOR FORCES THE
SKIPN D.BCL(I16) ; BYTE-CNT FOR BINNARY MODE TO BE
JUMPN AC4,REDWX ; AN INTEGRAL NUMBER OF WORDS
REDW1: PUSHJ PP,RECH ; GET A CHAR
POPJ PP, ; END-OF-FILE RETURN
MOVE AC4,C ; INTO AC4
LDB AC2,[POINT 6,D.IBB(I16),11] ; GET BYTE SIZE
LSH AC4,(AC2) ; MAKE ROOM FOR NEXT BYTE
PUSHJ PP,RECH ; GET CHAR
JUMPE AC4,RET.1 ; EOF RETURN
IOR AC4,C ; THE ?DW IS NOW IN AC4
PUSHJ PP,RECH ; SKIP OVER THE NEXT TWO CHARS
JUMPN AC4,RERE0 ; COMPLAIN IF EOF AND DATA
TRNE C,777677 ;[476] IF NOT BLANK (100) OR ZERO (0)
PUSHJ PP,RERE6 ; ERROR
PUSHJ PP,RECH ; SKIP LAST CHAR
JUMPN AC4,RERE0 ; COMPLAIN IF EOF AND DATA
TRNE C,777677 ;[476] IF NOT BLANK (100) OR ZERO (0)
PUSHJ PP,RERE6 ; ERROR
JRST RET.2 ; NORMAL EXIT
;HERE WHEN BYTE-CNT WAS WRONG, SHLD HAVE BEEN 0
REDWX: SETZB AC4,D.IBC(I16) ; ?DW IS 0 AND BUFFER IS EMPTY!
JRST RET.2 ;
;HERE IF GOT SOME DATA AND EOF INSTEAD OF ?DW
RERE0: MOVEI AC0,FE%39 ; YES GIVE AN ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE ERROR?
POPJ PP, ; YES - EOF RETURN
OUTSTR [ASCIZ "Got an EOF in middle of block/record descriptor word."]
JRST ERRMR ; ERROR MESS AND KILL
;ERROR BDW = 4 OR LESS
RERE1: MOVEI AC0,FE%40 ; GIVE AN ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE ERROR?
JRST RER10 ; YES - GET NEXT LOG-BLOCK
OUTSTR [ASCIZ /Block descriptor word byte count is less than five./]
JRST ERRMR ; ERROR MESSAGE AND KILL
;ERROR - RDW LE 0 AND WE GOT ANOTHER BUFFER OF WHAT?
RERE2: MOVEI AC0,FE%41 ; GIVE AN ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE ERROR?
JRST READEF ; YES - TAKE END-OF-FILE RETURN
OUTSTR [ASCIZ /Error - got another buffer instead of "EOF"./]
JRST ERRMR ; ERROR MESSAGE AND KILL
;ERROR - RDW PUTS END OF RECORD BEYOND D.FCPL
RERE3: MOVEI AC0,FE%42 ; GIVE AN ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE ERROR?
JRST RER6 ; YES - GIVE HIM "RECORD" ANYHOW
OUTSTR [ASCIZ /Error record extends beyond the end of the logical block./]
JRST ERRMR ; ERROR MESSAGE AND KILL
;GOT AN EOF IN MIDDLE OF A RECORD
RERE4: CAMN AC3,AC4 ; ANY NON-NULL CHARACTERS SEEN?
JRST READEF ; NO - GIVE ATEND RETURN
JRST REAAE1 ; YEP - ERROR
;BUFFER REC SIZE DIFFERS FROM THE ONE HE'S TRYING TO WRITE
RERE5: MOVEI AC1,4(AC3) ; IN CASE HE IGNORES THE ERROR
MOVEI AC0,FE%43 ; ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE ERROR?
JRST RNER32 ; YEP
OUTSTR [ASCIZ /It is illegal to change the record size of an EBCDIC IO record./]
JRST ERRMR ;
;ONE OF THE TWO LOW ORDER B/RDW BYTES IS NON-ZERO (SPANNED RECORDS?)
RERE6: MOVEI AC0,FE%44 ; ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE ERROR?
POPJ PP, ; YES
OUTSTR [ASCIZ "
?The two low order bytes of RDW/BDW must be zero, SPANNED EBCDIC not supported."]
JRST ERRMR ; NO, COMPLAIN
;HERE IF FILE OPTIONAL AND NOT PRESENT
RERE7: TLOE FLG,ATEND ;SET "AT END" PATH TAKEN
JRST REAAEE ;FATAL THE SECOND TIME
MOVEM FLG,F.WFLG(I16) ;SAVE FLG
MOVEI AC0,FS%10 ;GIVE AT END ERROR
SKIPL WANT8. ;UNLESS WANTS -8x STATUS
JRST RERE7B ;NO, 74 IS WHAT WE WANT
LDB AC0,F.BFAM ;GET ACCESS MODE
JUMPE AC0,RERE7A ;SEQUENTIAL ACCESS
TXNE AC16,V%RNXT ; OR READ NEXT
JRST RERE7A ; IS ERROR 15
;OTHERWISE IT IS START OR READ WITH INV KEY
MOVEI AC0,FS%25 ; WHICH IS ERROR 25
JRST RERE7B
RERE7A: MOVEI AC0,FS%15 ;SET UP FILE STATUS 15 FOR SEQUENTIAL READ
RERE7B: PUSHJ PP,SET10A ;SET FILE STATUS .. THIS ROUTINE SAVES
; AC0 IN FS.FS AS ITS FIRST STEP
JRST RET.2 ;SKIP EXIT
RNULER: MOVE AC0,D.LBN(I16) ; GET LAST BLK NUMBER,IF THERE IS ONE
JUMPE AC0,RNRNUA ; NONE, GIVE ERROR
CAME AC0,D.CBN(I16) ; SKIP IF LAST BLOCK
JRST RNRNUA ; NO(T) LAST BLOCK,ERROR
SETZM R.WRIT(I12) ; ZERO THE WRITE FLAG
MOVEI AC0,RDLAST ;THIS ONE ALSO
ANDCAM AC0,D.RFLG(I16)
TLO FLG,ATEND ; SET ATEND FLAG
JRST RANXI0 ; TAKE ATEND RETURN
RNRNUA: OUTSTR [ASCIZ/Read null record within V format sequential file.
/]
JRST ERRMR ; EXIT WITH ERROR
;READ AN "EOF". TAKE "AT-END" PATH. ***POPJ***
READEF: PUSHJ PP,SETS10 ;[601] SET ATEND STATUS
MOVEM FLG,F.WFLG(I16) ;SAVE THE FLAG REGISTER
LDB AC5,F.BPMT ;FILE TABLE - FILE POSITION
JUMPN AC5,RET.2 ;SKIP EXIT TO THE ***"ACP"***
HLLZ FLG1,D.F1(I16) ;FLAGS
TXNE AC13,DV.MTA ;SKIP IF NOT A MTA,ETC.
TXNN FLG1,B%STL ;SKIP IF STANDARD LABELS
JRST RET.2 ;SKIP EXIT TO THE ***"ACP"***
PUSHJ PP,CLSRL ;READ IN THE LABEL
XCT MBSPR. ;BACK OVER THE LABEL
PUSHJ PP,CLSEOV ;CHECK FOR "EOV"
JRST READE1 ;OK
JRST RET.2 ;SKIP EXIT TO ***ACP***
READE1: PUSHJ PP,CLRSTS ;[601]CLEAR FILE STATUS
HRLI AC16,(V%CLOS+CLS%CR) ;CLOSE REEL
PUSHJ PP,C.CLOS ;A READ GENERATED CLOSE
HRLI AC16,2100 ;READ
TLZ FLG,ATEND ;TURN OFF THE EOF FLAG
MOVEM FLG,F.WFLG(I16) ; ALSO IN THE FILE TABLE
JRST READ. ;TRY AGAIN
;READ A CHARACTER. IGNORE ASCII NULLS. ***POPJ***
;[577] HAM 7-JUN-79
;[577] THE FOLLOWING KLUDGE CHECKS FOR THE NO CRFL AT END OF MTA
;[577] RECORD. IN CASE WHEN THIS IS DETECTED, A SIMPLE RETURN TO CALLER
;[577] IS MADE. THIS ASSUMES THAT THIS CASE WILL ONLY OCCUR AFTER
;[577] THE ACTUAL RECORD BODY HAS BEEN READ IN, AND THAT THE SEARCH FOR
;[577] 'EOL' CHARS IS ON. THUS ONLY AT THE RETURN FROM READCH AT READ7:
;[577] IS THE CHECK FOR THIS CASE MADE.
;[577] AC5 NEGATIVE INDICATES THE MTA EOR CASE
; [12-B] REMOVED MTA BLOCK-1 CASE, TAKEN CARE OF FOR GENERAL CASE
READCH: SOSLE D.IBC(I16) ;[577] DECREMENT BYTE COUNT,SKIP IF BUFFER EMPTY
JRST REDCHB ;[577] GO ON IF MORE DATA IN BUFFER
; DON'T GET ANOTHER BUFFER IF ASCII END OF LOGICAL BLOCK
REDCHA: JUMPGE FLG,REDCHC ; CONTINUE IF NOT ASCII
LDB C,F.BBKF ; GET BLOCKING FACTOR
JUMPE C,REDCHC ; CONTINUE IF UNBLOCKED
SKIPE D.BCL(I16) ; SKIP IF NO BUFFERS IN CURRENT LOG-BLK
JRST REDCHC ; ELSE CONTINUE
MOVEI C,$CR ; INDICATE END OF RECORD
POPJ PP, ; AND RETURN
REDCHC: PUSHJ PP,READBF ;[577] INPUT IF YOU MUST
TLNE FLG,ATEND ;[577] SKIP IF NOT AT END ("EOF")
POPJ PP, ;
REDCHB: ILDB C,D.IBB(I16) ;RETURN WITH A CHAR IN C
IFE SIRUS,<
SKIPN C ;SKIP IF NOT A NULL CHAR
JUMPL FLG,READCH ;IGNORE IT IF IT IS A ASCII NULL
POPJ PP, ;
>
IFN SIRUS,<
JUMPGE FLG,READCX ; [403] IF NOT ASCII FILE RETURN
SKIPE C ; [403] OTHER WISE SKIP NULLS
CAIN C,$CR ; [403] OR <CR>
JRST READCH ; [403]
READCX: POPJ PP, ; [403] RETURN
>
READBF: PUSHJ PP,READIN ;GET A BUFFER
TRN
SOS D.BCL(I16) ;DECREMENT BUF/LOGBU
POPJ PP, ;
;BLT BUFFER/S TO THE RECORD AREA
REABR: HRR AC5,FLG ;RECORD AREA I.E. "TO"
MOVE AC0,AC3 ;SAVE ACTUAL RECORD SIZE
REABR1: MOVE AC11,AC3 ;SETUP FOR THE "UNTIL"
SUB AC3,D.IBC(I16) ;REC-SIZE MINUS BYTE-COUNT
JUMPGE AC3,REABR2 ;JUMP, USE ALL OF CURRENT BUFFER
MOVN AC3,AC11 ;SO WE CAN ADJ THE BYTE-COUNT
JRST REABR3 ;
REABR2: MOVE AC11,D.IBC(I16) ;BYTE-COUNT
SETZM D.IBC(I16) ;NOTE THE BUFFER IS EMPTY
REABR3: IDIVI AC11,6 ;CONVERT TO WORDS
JUMPE AC12,REABR4 ;CHECK THE REMAINDER
ADDI AC11,1 ;ADJ WRDCNT IF THERE WAS ONE
SUBI AC12,6 ;NEGATE TRAILING NULL BYTES
REABR4: SKIPE D.IBC(I16) ;SKIP IF THE BUFFER IS EMPTY
ADD AC12,AC3 ;ADD IN THE REC-SIZE
ADDM AC12,D.IBC(I16) ;SUBTRACT FROM THE BYTE-COUNT
HRL AC5,D.IBB(I16) ;"FROM"
HRRZ AC4,AC5 ;
ADDI AC4,-1(AC11) ;"UNTIL"
BLT AC5,(AC4) ;SLURP P P !!
HRRI AC5,1(AC4) ;NEW "TO"
ADDM AC11,D.IBB(I16) ;RESTORE THE BYTE-POINTER
SKIPLE D.IBC(I16) ;READ8 IF YOU CAN
JRST REABR5 ;EXIT
JUMPLE AC3,REABR5 ;EXIT IF ALL WAS BLT'ED
PUSHJ PP,READBF ;ADVANCE TO NEXT BUFFER
PUSHJ PP,REAABP ;ADJ BYTE-PTR
TLNN FLG,ATEND ;SKIP IF "EOF" WAS SEEN
JRST REABR1 ;LOOP
REABR5: ADDI AC0,5 ;ACTUAL SIZE
LDB AC2,F.BMRS ;MAX SIZE
ADDI AC2,5 ;ROUND UP
CAMN AC0,AC2 ;IF THE SAME
JRST READ8 ; EXIT
IDIVI AC0,6 ;CONVERT TO
IDIVI AC2,6 ; WORDS
SUB AC2,AC0 ;NUMBER OF WORDS TO ZERO FILL
JUMPE AC2,READ8 ;EXIT IF NONE
REABR6: SETZM 1(AC4)
SOJLE AC2,READ8
AOJA AC4,REABR6
REAAE1: MOVEI AC0,FE%25 ;ERROR NUMBER
PUSHJ PP,IGCVR ;IGNORE ERROR?
POPJ PP, ;YES
PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ/Encountered an "EOF" in the middle of a record./]
JRST REAAE0 ;AT END ERROR
;File is already AT END or second READ of non-existant optional file
REAAEE: TXNE FLG,IDXFIL ;INDEXED FILE?
SETOM FS.IF ;YES, SET FLAG
MOVEI AC0,FS%30 ;ERROR NUMBER FOR PERM ERROR
SKIPGE WANT8. ;DOES USER WANT ANS-8x EFFECT?
MOVEI AC0,FS%16 ;YES, RETURN WITH FILE STATUS = 16
MOVEM AC0,FS.FS ;
MOVEI AC0,FE%24
PUSHJ PP,IGCVR ;IGNORE ERROR?
JRST RET.2 ;YES
PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /The AT END path has been taken previously./]
REAAE0: MOVE AC2,[BYTE (5)10,31,20,21]
PUSHJ PP,MSOUT. ;KILL
;HERE IF RECORD SEQUENCE NUMBER FOUND IN LEFT SIDE OF MTA SIXBIT
;HEADER-WORD IS NOT EQUAL TO RECORD COUNT IN FILE TABLE
;NOTE. COUNT STARTS AT ZERO
REALR: SKIPN AC5,D.EXOF(I16) ; GET OPEN EXTEND RECORD SEQ OFFSET
JRST REALR1 ; JUMP IF NONE SET, CHECK FOR FIRST EXT REC
ADDI AC4,(AC5) ; ADD EXTEND OFFSET TO REC SEQ NUM
CAIE AC0,(AC4) ; SKIP IF OK WITH OFFSET
JRST REALR2 ; ELSE ERROR
JRST READ31 ; OPN EXT SECTION OK, CONT
; CHECK FOR READ REVERSED, AND IF FIRST REC READ REV, RESET D.RP
REALR1: HRRZ AC2,D.RFLG(I16) ; GET SOME FLAGS
TRNN AC2,RDDREV ; READ REVERSE OPEN ACTIVE?
JRST RELR1A ; NO CONT
CAIE AC0,-1 ; IS REC NUMBER -1?
JRST RELR1B ; NO, CHECK FOR FIRST REC
; IF REC COUNT = -1 CHECK FOR HDR LABEL
IFE TOPS20,<
HRRZ AC2,D.IBH(I16) ; GET BUFF HEADER ADDR
HLRZ AC0,(AC2) ; GET BUFF SIZE
TRZ AC0,400000 ; TURN OFF "X" BIT
HRRZ AC2,1(AC2) ; GET WORD COUNT
SUBI AC0,1(AC2) ; CALC POSITION TO FIRST WORD
; SUB EXTRA 1 FOR BUF SIZ EXTRA
ADD AC1,AC0 ; UPDATE POINTER
ADDM AC0,D.IBB(I16) ; AND IN FILTAB TOO
>; END IFE TOPS20
MOVE AC0,(AC1) ; GET THE FIRST WORD AGAIN
TRZ AC0,7777 ;
CAME AC0,[SIXBIT/HDR1/] ; IS THIS HDR1 LABEL?
JRST REALR2 ; NO, THEN ERROR
PUSHJ PP,READBF ; READ AGAIN, SHOULD GET ATEND.
TLNN FLG,ATEND ;SKIP IF "EOF" WAS SEEN
JRST REALR2 ; NO ERROR, NOT WHAT WE THOUGHT
JRST READEF ; YES ATEND, ALL OK , GO SET IT
RELR1B: SOJG AC0,REALR2 ; JUMP IF NOT FIRST RECORD READ
MOVEM AC4,D.RP(I16) ; ELSE RESET REC COUNT TO COUNT BACK
JRST READ31 ; AND CONT
RELR1A: SOJN AC4,REALR2 ; JUMP IF NOT REC NUM 1
SUBI AC0,1 ; ELSE SAVE THE OFFSET TO BEGINING
MOVEM AC0,D.EXOF(I16) ; OF THE EXTENDED RECORD SET
JRST READ31 ; TRY AGAIN
REALR2: MOVEI AC0,FE%26 ;ERROR NUMBER
PUSHJ PP,IGCVR ;IGNORE ERROR?
JRST READ31 ;YES TRY TO RETURN WHAT YOU GOT
OUTSTR [ASCIZ /record-sequence-number /]
HRLO AC12,AC4 ;RSN
PUSHJ PP,PPOUT4 ;TYPE IT
OUTSTR [ASCIZ / should be /]
HRLO AC12,D.RP(I16) ;RECORD COUNT
PUSHJ PP,PPOUT4 ;TYPE IT
JRST REAAE0 ;FINISH UP MESSAGE
;ADJUST BYTE-POINTER TO NON-EX BYTE LEFT OF NEXT WORD
REAABP: SKIPGE AC1,D.IBB(I16) ;
POPJ PP, ;
TLZ AC1,770000 ;
ADD AC1,[POINT ,1] ;
MOVEM AC1,D.IBB(I16) ;
POPJ PP, ;
;SETUP AC10 WITH CONVERSION INST. ***POPJ***
REAXCT: TLNE FLG,DDMBIN ;IF BINARY,
JRST REAXC2 ; NO CONVERSION
JUMPL FLG,REAXC1 ;JUMP IF DEV IS ASCII
MOVE AC10,[ADDI C,40] ;ASCII TO SIXBIT
TLNE FLG,CDMSIX ;SKIP IF CORE-DATA-MODE IS NOT SIXBIT
REAXC2: MOVSI AC10,(TRN) ;6BIT T0 6BIT (LABELS)
POPJ PP, ;
REAXC1: MOVE AC10,[MOVE C,CHTAB(C)] ;ASCII TO ASCII
TLNE FLG,CDMSIX ;
TLO AC10,4000 ;SIXBIT TO ASCII (MOVE TO MOVS)
POPJ PP,
SUBTTL START VERB
;A START VERB LOOKS LIKE:
;MOVE 16,[FLAGS,,<FILE TABLE ADDRESS>]
;MOVEI 1,<SIZE OF APPROXIMATE KEY> ;OPTIONAL
;PUSHJ 17,C.STRT
;RETURN+1 NORMAL RETURN
;RETURN+2 "INVALID KEY" RETURN
;FLAGS ARE:
;STA%AP APPROXIMATE KEY (SIZE IN 1(16))
;STA%EQ EQUAL TO (BITS 0 IF THIS)
;STA%NL NOT LESS THAN
;STA%GT GREATER THAN
;THE APPROXIMATE KEY SIZE IS STORED IN F.AKS(I16)
C.STRT:
SKIPE F.WSMU(I16) ;[1162] Doing SMU on this file
SKIPN SU.RR ;[1162] Yes, within scope of retain/free
SKIPA ;[1162] Everything OK
JRST STRT.E ;[1162] Can't do START within RETAIN
TXO AC16,V%STRT ;SET FAKE READ BIT
TXNE AC16,STA%AP ;IF APPROXIMATE KEY
MOVEM AC1,F.AKS(I16) ;PUT SIZE IN A SAFE PLACE
JRST FAKER. ;[1162]AND DO FAKE READ
STRT.0: TXNN AC16,STA%EQ ;TEST FOR =
JRST STRT.I ;YES, FAIL FIRST TIME
HRRZ AC1,F.RACK(I16) ;GET POINTER TO RELATIVE KEY
JUMPE AC1,STRT.I ;NO KEY
AOS (AC1) ;INCREMENT
JRST RANDOM ;TRY AGAIN
STRT.I: PUSHJ PP,SETS23 ; SET REC NOT FOUND (23)
JRST RET.2 ;AND GIVE ERROR RETURN
STRT.E: OUTSTR [ASCIZ/Attempt to execute START verb within scope of RETAIN and FREE statements/]
SUBTTL RANDOM/IO-STUFF
;RANDOM AND IO READ AND WRITE ENTER HERE FROM READ. OR WRITE.
; DUMP MODE POINTERS
;(I12)R.IOWD DUMP MODE IOWD
;(I12)R.TERM TERMINATOR
;(I12)R.BPNR BYTE-POINTER TO NEXT RECORD
;(I12)R.BPLR BYTE-POINTER TO LAST RECORD
;(I12)R.BPFR BYTE POINTER TO FIRST RECORD
;(I12)+5 NOT USED
;(I12)R.DATA -1 IF ACTIVE DATA IN BUFFER
;(I12)R.WRIT -1 IF LAST UUO WAS A WRITE
;(I12)R.FLMT AOBJ PTR TO FILE LIMITS
;(I12)R.DLRW BLK NUMBER SAVED BEFORE DEL/REWRT
;READ IN THE LOGICAL BLOCK, AND POINT AT THE RECORD.
RANDOM: SETZ AC4, ; [431] ASSUME ACTUAL KEY IS ZERO
HLLZ FLG1,D.F1(I16) ;GET FLAGS
HLRZ I12,D.BL(I16) ;POINTER TO DUMP MODE POINTERS
TLNN FLG,RANFIL ;SKIP IF NOT SEQIO
JRST SEQIO ;
PUSHJ PP,SETKEY ;SET AND CHECK RELATIVE KEY
LDB AC2,F.BBKF ;BLOCKING FACTOR
SKIPN AC1,AC4 ;ZERO MEANS GET NEXT RECORD
AOSA AC1,D.RP(I16) ;ZERO! SO LAST KEY PLUS ONE
MOVEM AC1,D.RP(I16) ;SAVE IT HERE TOO
MOVEM AC1,FS.RN ;SAVE FOR ERROR-STATUS
SOSN AC1 ;[300]
TDZA AC2,AC2 ;
IDIV AC1,AC2 ;
IMUL AC1,D.BPL(I16) ;BUFFER PER BLOCK
ADDI AC1,1 ;PHYS. BLOCK NUMBER FOR USETI
MOVEM AC1,FS.BN ;SAVE IT FOR ERROR-STATUS
JUMPE AC4,SEQIOZ ;[461] IF ACT-KEY = 0, READ SEQUENTIALLY
CAME AC1,D.CBN(I16) ;SKIP IF RECORD IS IN CORE
PUSHJ PP,RANIN ;OTHERWISE GET IT
SKIPA AC5,R.BPFR(I12) ;BYTE POINTER TO THE FIRST RECORD
JRST RANXI8 ;[273] EOF
LDB AC0,F.BBKF ;HOW MANY RECORDS ARE LEFT
SUBI AC0,1(AC2) ; IN THIS LOGICAL BLOCK.
SETZM D.SRCL(I16) ; CLEAR ANY SAVED D.RCL AFTER DEL/REWRT
TXNN AC16,V%DLT+V%RWRT ; IS THIS DELETE OR RERIT?
JRST RDKYD5 ; NO, CONT
LDB AC11,F.BFAM ; GET ACCESS MODE
JUMPE AC11,RDKYD5 ; IF SEQ ACCESS SKIP THIS SAVE
; IN THIS CASE D.RCL WILL BE OK
MOVE AC11,D.RCL(I16) ; ELSE,GET CURRENT RECS LEFT IN LOG-BLK
MOVEM AC11,D.SRCL(I16) ; SAVE IT HERE FOR POSSIBLE SEQ READ NEXT
RDKYD5: MOVEM AC0,D.RCL(I16) ;SAVE FOR RANSHF
TLNE FLG,DDMBIN ;IF BINARY,
JRST RANDO7 ; GO TO SPECIAL ROUTINE
JUMPL FLG,RANA01 ;JUMP IF ASCII
TLNE FLG,DDMEBC ; IF EBCDIC FILE
JRST RNER ; GO HERE
JUMPE AC2,RANDO2 ;JUMP IF WE'RE DONE
LDB AC0,F.BMRS ;MAX-REC-SIZ
RANDO1: HRRZ AC10,@AC5 ;RECORD SIZE IN CHARS
;ANDI AC10,7777 ;
CAMGE AC0,AC10 ;IS CHAR-CNT TOO LARGE?
JRST RANDO2 ;COMPLAIN
IDIVI AC10,6 ;RECORD
SKIPE AC11 ;SIZE
ADDI AC10,1 ;IN
ADDI AC5,1(AC10) ;WORDS
SOJG AC2,RANDO1 ;JUMP TILL NXTREC=CURREC
TXNN AC16,V%DLT+V%RWRT ; IS THIS DELETE OR RERIT?
JRST RAND2A ; NO, CONT
LDB AC0,F.BFAM ; GET ACCESS MODE
CAIN AC0,%FAM.S ; IF NOT SEQ ACCESS SKIP POSITION CHANGE
RAND2A: MOVEM AC5,R.BPNR(I12) ;SAVE AS CURRENT RECORD
;HERE TO CHECK THAT NEW RECORD SIZE IS BETWEEN MIN AND MAX
RANDO2: HRRZ AC2,@AC5 ;RECORD SIZE IN CHARACTERS
JUMPE AC2,RNDO19 ;NO TEST IF ZERO
LDB AC0,F.BLRS ;MIN RECORD SIZE
CAML AC2,AC0 ;IS RECORD LESS THAN MINIMUM
JRST RNDO19 ;NO
PUSHJ PP,ERRLR2 ;ERROR MESSAGE
;PRINT WARNING THAT RECORD LENGTH FIELD (SIXBIT OR V FORMAT)
;IS SMALLER THAN FD MINIMUM
OUTSTR [ASCIZ/%Record length field smaller than FD minimum.
/]
HRRZ AC2,@AC5 ;GET RECORD SIZE AGAIN
RNDO19: LDB AC0,F.BMRS ;MAX RECORD SIZE
CAMG AC2,AC0 ;[613] LE THAN MAX?
JRST RNDO20 ;[613] YES, CONT
PUSHJ PP,ERRMR1 ;NO - GO COMPLAIN
;[613] HERE IF ERROR IGNORED BY USE PROCEDURE
;[613] GIVE WARNING ABOUT WHAT WE ARE ASSUMING AND SET TO USE
;[613] MAX REC SIZE AS THE CORRECT ONE
HRRM AC0,@AC5 ;[613] RESET RECORD LENGTH TO BE MAX
; AC2 LOADED WITH MAX SIZE IN ERRMR0
;[613] PRINT WARNING THAT RECORD LENGTH FIELD (SIXBIT OR V FORMAT)
;[613] IS LARGER THAN FD MAXIMUM
OUTSTR [ASCIZ/%Record length field larger than FD maximum, assuming max.
/]
RNDO20: JUMPN AC2,RANWRZ ;ONWARD IF NOT A ZERO LENGTH RECORD
TXNN AC16,V%READ!V%RWRT ;READ OR REWRITE?
JRST RANWR0 ;WRITE OR DELETE!
TXNE AC16,V%STRT ;START VERB?
JRST STRT.0 ;YES, NON-EXISTENT RECORD
LDB AC1,F.BFAM ;GET ACCESS MODE
TLNE FLG,RANFIL ;A RANDOM FILE?
JUMPN AC1,[TXNE AC16,V%RNXT ;YES, BUT READ NEXT IS OK
JRST .+1 ;READ NEXT WINS
JRST RANDO3] ;RANDOM LOSES
SKIPN NRSAV. ;[426] IF WE ALREADY HAVE START OF NULL STRING
SKIPN AC1,D.LBN(I16) ;[426] OR IF NOT AN IO FILE
JRST RNDO21 ;[426] JUMP
CAMLE AC1,D.CBN(I16) ;[426] IS THIS THE LAST BLOCK OF FILE?
JRST RNDO21 ;[426] NO
MOVE AC1,[-5,,NRSAV.-1] ;[426] SAVE PTRS TO LAST REAL REC
PUSH AC1,R.BPNR(I12) ;[426]
PUSH AC1,FS.RN ;[426]
PUSH AC1,D.RP(I16) ;[426]
PUSH AC1,D.RCL(I16) ;[426]
RNDO21: MOVE AC0,R.BPNR(I12) ;[426] YES - HERE TO GET NEXT NON-0-RECORD
MOVEM AC0,R.BPLR(I12) ; BUT FIRST UPDATE
AOS R.BPNR(I12) ; THE POINTERS
HRRZ AC0,D.WPR(I16) ; GET WORDS PER RECORD
SUBI AC0,1 ; DECREMENT FOR AOS ABOVE
JUMPGE FLG,RNDO22 ; JUMP IF NOT ASCII
TLNE FLG,RANFIL ; SKIP IF NOT A RANDOM FILE I.E.SEQ
ADDM AC0,R.BPNR(I12) ; POSITION TO NEXT RECORD
RNDO22: AOS D.RP(I16) ;COUNT 0LEN RECORDS
AOS FS.RN ;BUMP THE RECORD NUMBER
HRRZ AC1,F.RACK(I16) ;GET POINTER TO RELATIVE KEY
SKIPE AC1
AOS (AC1) ;POINT TO RECORD WE WILL GET NEXT TRY
AOJA AC5,SQIO2 ;FIND THE NEXT ONE
;HERE IF RECORD NOT FOUND
RANDO3: PUSHJ PP,SETS23 ;[601] SET FILE STATUS TO 23
TLNE FLG,RANFIL ;SKIP IF NOT A RANDOM FILE
JRST RANDO4 ;RANDOM JUMPS
SOS D.RP(I16) ;DONT COUNT THIS ONE
AOS D.RCL(I16) ;DONT COUNT "EOF" AS A RECORD
TLO FLG,ATEND ;SET "EOF" FLAG
RANDO4: TXNN AC16,V%DLT+V%RWRT ; IS THIS DELETE OR RERIT?
JRST RNDO4A ; NO, CONT
LDB AC0,F.BFAM ; GET ACCESS MODE
JUMPN AC0,RANXI3 ; IF NOT SEQ ACCESS SKIP POSITION CHANGE
RNDO4A: MOVE AC0,R.BPNR(I12) ;UPDATE POINTERS IN CASE HE WANTS TO
TLNE FLG,RANFIL ;RANDOM FILE?
HRRI AC0,(AC5) ;YES, USE THIS REC POINTER
MOVEM AC0,R.BPLR(I12) ; WRITE AFTER "EOF"
HRRM AC5,R.BPNR(I12) ;MAKE THIS THE NEXT RECORD
AOS R.BPNR(I12) ; NEXT
HRRZ AC0,D.WPR(I16) ; GET WORDS PER RECORD
SUBI AC0,1 ; DECREMENT FOR AOS ABOVE
JUMPGE FLG,RNDO41 ; JUMP IF NOT ASCII
TLNE FLG,RANFIL ; SKIP IF NOT A RANDOM FILE I.E.SEQ
ADDM AC0,R.BPNR(I12) ; POSITION TO NEXT RECORD
RNDO41: JRST RANXI3 ;RETURN
;HERE TO POSITION TO ASCII REC WITHIN LOGICAL BLOCK
RANA01: TLNN FLG,RANFIL ; SKIP IF A RANDOM FILE
SKIPN (AC5) ; SKIP IF SEQIO NON-NULL RECORD
TRNA ; RANDOM OR NULL RECORD SKIPS
JRST RANA09 ; WE DONT HAVE TO POSITION
HRRZ AC10,D.WPR(I16) ; GET WORDS PER RECORD
IMUL AC10,AC2 ; GET OFFSET TO FIRST REC WRD
ADDI AC5,(AC10) ; POINT BYTE-PTR AT RECORD
TXNN AC16,V%DLT+V%RWRT ; IS THIS DELETE OR RERIT?
JRST RAN09X ; NO, CONT
LDB AC0,F.BFAM ; GET ACCESS MODE
JUMPE AC0,RAN09X ; IF SEQ ACCESS POSITION CHANGE
PUSH PP,AC5 ; DELETE-RERIT, SAVE START POS
TDNA ; AND SKIP
RAN09X: MOVEM AC5,R.BPNR(I12) ; SAVE IT AWAY
; CHECK WHOLE RECORD FOR NULL CASE
RANA09: MOVE AC1,D.WPR(I16) ;[670] GET WORDS PER RECORD
TLNE FLG,DDMBIN ;[670] UNLESS DOING BINARY
MOVE AC1,AC10 ;[670] THEN WPR IS IN AC10
RAN09A: MOVE AC2,(AC5) ;[670] GET A RECORD WORD
JUMPN AC2,RAN09B ;[670] CONTINUE WHEN NON-NULL FOUND
SOJLE AC1,RAN09B ;[670] OR WHEN WHOLE RECORD CHECKED
AOJA AC5,RAN09A ;[670] TRY NEXT WORD
RAN09B: TXNN AC16,V%DLT+V%RWRT ; IS THIS DELETE OR RERIT?
JRST RAN09Y ; NO, RESET NEXT RECORD
LDB AC0,F.BFAM ; GET ACCESS MODE
JUMPE AC0,RAN09Y ; IF SEQ ACCESS CONT
POP PP,AC5 ; DELETE-RERIT,RESTORE START POS
TDNA ; AND SKIP (DON'T USE NEXT REC )
RAN09Y: MOVE AC5,R.BPNR(I12) ;[670] RESET BYTE POINTER
JRST RNDO20 ; CONT
;FILE IS BINARY.
;STEP DOWN TO CORRECT RECORD AND MOVE TO/FROM RECORD AREA.
RANDO7: LDB AC10,F.BMRS ;GET MAXIMUM RECORD SIZE
LDB AC11,[POINT 2,FLG,14] ; GET CORE DATA MODE
HRRZ AC11,RBPTBL(AC11) ; GET CHARS PER WORD
ADDI AC10,-1(AC11) ; *
IDIVI AC10,(AC11) ; *
MOVE AC11,AC10 ;SAVE IT
IMULI AC11,(AC2) ;MULTIPLY BY # RECORDS FROM TOP
ADD AC5,AC11 ;ADD TO RECORD BYTE POINTER
TXNN AC16,V%DLT+V%RWRT ; IS THIS DELETE OR RERIT?
JRST RNDO7A ; NO, CONT
LDB AC0,F.BFAM ; GET ACCESS MODE
JUMPE AC0,RNDO7A ; IF SEQ ACCESS POSITION CHANGE
PUSH PP,AC5 ; DELETE-RERIT, SAVE START POS
JRST RANA09 ; AND CHECK FOR NULL RECORD
RNDO7A: MOVEM AC5,R.BPNR(I12) ;SAVE AS CURRENT RECORD
JRST RANA09 ;[670] CHECK FOR NULL RECORD
RAND7A: HRL AC5,FLG ;[670] GET RECORD ADDRESS
TXNN AC16,V%READ ;IS IT READ?
JRST RANDO9 ;NO
MOVSS AC5 ;YES--MOVING TO RECORD
SETZM R.WRIT(I12) ;REMEMBER IT WAS A READ
MOVEI AC0,RDLAST ;TURN ON VALID READ FLAG
IORM AC0,D.RFLG(I16)
JRST RAND10
RANDO9: SETOM R.DATA(I12) ;FORCE WRITE LATER
SETOM R.WRIT(I12) ;REMEMBER IT WAS A WRITE
TXNN AC16,V%DLT ; IS THIS DELETE??
JRST RAND10 ; NO,GO ON
HRLS AC5 ; YES,SET SO IT WILL BLT TO ITSELF
SETZM (AC5) ; CLEAR FIRST WORD
ADDI AC5,1 ; SET TO BLT . TO .+1
SUBI AC10,1 ;DECREMENT THIS TO MAKE UP FOR ADD ABOVE
RAND10: ADDI AC10,(AC5) ;FINAL DESTINATION PLUS 1
BLT AC5,-1(AC10) ;BLAT!!
TXNE AC16,V%READ ;IS IT READ?
MOVSS AC5 ;YES,RESET AC5 TO GET BUFFER ADDR IN RIGHT HALF
JRST RANXIT
;SEQUENTIAL IO READ AND WRITE ARE PROCESSED HERE
SEQIOZ: SETZM NRSAV. ;[461] CLEAR SO WRONG BYTE POINTERS
;[461] DON'T GET POP'D
SEQIO: SKIPN AC5,D.SRCL(I16) ; SKIP AND LOAD IF SAVED D.RCL AFT DEL/REWRT
JRST SEQI00 ; ELSE, CONT
MOVEM AC5,D.RCL(I16) ; RESTORE IT
SETZM D.SRCL(I16) ; CLEAR SAVED VALUE
SEQI00: HRRZ AC5,F.RACK(I16) ;IF THERE IS A RELATIVE KEY
JUMPE AC5,SEQIO0 ;NOT
PUSH PP,D.RP(I16) ;THEN UPDATE IT
POP PP,0(AC5) ;WITH NEW VALUE
SEQIO0: SKIPE R.BPLR(I12) ;SKIP IF FIRST INPUT
JRST SQIO1 ;ITS NOT
MOVE AC5,R.BPFR(I12) ;FIRST RECORD
MOVEM AC5,R.BPLR(I12) ;LAST RECORD
MOVEI AC1,1 ;FIRST BLOCK
JRST SQIO11 ;READ IT IN
; IF R.DLRW(I12) SET THEN READ BACK "CURRENT" DSK BLK
SQIO1: SKIPN AC1,R.DLRW(I12) ; IS DEL/RERIT BLK NUM SAVED?
JRST SQIO1A ; NO, CONT
TXO AC16,V%DLT ; FAKE OUT RANIN NOT T O RESET "CURRENT" LOC
PUSHJ PP,RANIN ; YES, READ IT INTO THE BUFFER
JRST SQIO1B ; OK, BLK IN BUFFER
; TROUBLE, BLOCK WE USED TO HAVE ISN'T THERE NOW
OUTSTR [ASCIZ/?Internal error, no DELETE-REWRITE "current" DSK blk.
/]
JRST KILL. ; GIVE UP
SQIO1B: TXZ AC16,V%DLT ; CLEAR FAKE OUT
SQIO1A: SKIPN R.WRIT(I12) ;SKIP IF WRITE WAS LAST
TXNN AC16,V%RWRT!V%DLT ;SKIP IF REWRITE OR DELETE AFTER READ
SQIO2: SKIPA AC1,D.RCL(I16) ;NUMBER OF REC TO FILL CURRENT LOGBLK
JRST SQIO20 ;
SQIO4: JUMPN AC1,SQIO30 ;JUMP IF RECORD IS IN CORE
SKIPN NRSAV. ; NON-ZERO MEANS THIS IS LAST BLOCK
JRST SQIO10 ; NOT THE LAST BLOCK OF FILE
MOVE AC0,[-5,,NRSAV.+3]; IT IS SO BACK UP TO
POP AC0,D.RCL(I16) ; THE RECORD POSITION
AOS D.RCL(I16) ;
POP AC0,D.RP(I16) ; JUST AFTER THE LAST
POP AC0,FS.RN ; REAL RECORD SO APPEND
POP AC0,R.BPLR(I12) ; WILL FIND THE RIGHT RECORD SLOT
MOVE AC0,R.BPLR(I12) ; NOW, MAKE THE NEXT RECORD SLOT
MOVEM AC0,R.BPNR(I12) ; BE THE SAME AS THE LAST RECORD SLOT
SETZM NRSAV. ; ZERO NULL-REC-IN-LAST-BLOCK FLAG
SETZM R.WRIT(I12) ; ZERO THE WRITE FLAG
TLO FLG,ATEND ; SET ATEND FLAG
PUSHJ PP,SETS10 ; [601] NO NEXT REC STATUS (10)
HRRZ AC4,F.RACK(I16) ; GET POINTER TO RELATIVE KEY
JUMPE AC4,RANXI0 ; DONT RESTORE NONEX KEY
MOVE AC0,NRSAV.+4 ; GET ORIGINAL KEY
MOVEM AC0,(AC4) ; AND RESTORE IT
JRST RANXI0 ; AND GIVE ATEND RETURN
;HERE TO GET THE NEXT LOGICAL BLOCK
SQIO10: HRRZ AC1,D.BPL(I16) ;BUFFERS PER LOGBLK
ADD AC1,D.CBN(I16) ;USETI OPERAND (CURRENT PHYS BLOCK)
SQIO11: PUSHJ PP,RANIN ;WRITE LAST BLOCK IF NECESSARY,THEN INPUT
JRST SQIO30 ;NOW THE RECORD IS IN CORE
TXNN AC16,V%READ ;SKIP IF NOT WRITE AFTER EOF
JRST SQIO30 ;WRITE
MOVE AC0,R.BPFR(I12) ;BP TO FIRST REC
MOVEM AC0,R.BPLR(I12) ; = BP TO LAST REC
JRST RANXI0 ;[273]
;HERE ON WRITE AFTER READ
SQIO20:
SQIO21: SOS D.RP(I16) ;THIS REC HAS BEEN COUNTED
SOS FS.RN ;BEEN COUNTED BY PREVIOUS READ
MOVE AC5,R.BPLR(I12) ;BP TO LAST RECORD
MOVEM AC5,R.BPNR(I12) ;BP TO NEXT RECORD
TLNE FLG,ATEND ;[322] IF ATEND THEN
SOS D.RCL(I16) ;[322] DECREMENT REC/LOGBLK CNT
JRST SQIO32 ;
;HERE WHEN RECORD IS IN CORE
SQIO30: TLNN FLG,ATEND ;APPENDING?
JRST SQIO31 ; NOT APPENDING
TLNN FLG,DDMEBC!DDMASC ;[526] NO REC-CNT IF EBC
MOVEM AC3,@R.BPNR(I12);GIVE A REC-CNT
SQIO31: SOS D.RCL(I16) ;DECREMENT REC/LOGBLK COUNT
MOVE AC5,R.BPNR(I12) ;CURRENT/NEXT RECORD
SQIO32: JUMPG FLG,SQIO33 ;JUMP IF NOT ASCII
TLNN FLG,SEQFIL ;SKIP IF SEQ FILE
JRST RANA09 ; NOT SEQ,GO ON
JRST RANWRT ; SEQ, SKIP WORD CHECKS
SQIO33: TLNE FLG,DDMBIN ;JUMP IF
JRST RANBIN ; IT IS A BINARY FILE
TLNE FLG,DDMEBC ; IF EBCDIC FILE
JRST RNES ; GO HERE
JRST RANDO2 ;GO CHECK THE RECORD SIZE
;ENTRY POINT FOR RANDOM EBCDIC FILES
;LOGICAL BLOCK IS IN CORE SO SETUP THE BYTE-POINTER
RNER: HRRZ AC10,D.WPR(I16) ; GET WORD OFFSET TO NEXT RECORD
IMUL AC10,AC2 ; GET NUMBER OF WORDS BEFORE THE DESIRED RECORD
ADDI AC5,(AC10) ; ADD THIS OFFSET TO BYTE-PTR
TXNN AC16,V%DLT+V%RWRT ; IS THIS DELETE OR RERIT?
JRST RNERAA ; NO, CONT
LDB AC0,F.BFAM ; GET ACCESS MODE
CAIN AC0,%FAM.S ; IF NOT SEQ ACCESS SKIP POSITION CHANGE
RNERAA: MOVEM AC5,R.BPNR(I12) ; UPDATE NEXT RECORD POINTER
;ENTRY POINT FOR SEQIO EBCDIC FILES
RNES: TXNN AC16,V%READ ; READ SKIPS
JRST RNER30 ; WRITE JUMPS
MOVE AC10,D.RCNV(I16); SETUP THE CONVERSION INST
SETZB AC0,R.WRIT(I12) ; READ WAS LAST
JUMPL FLG1,RNER10 ; BRANCH IF VAR-LEN RECORDS
;READ - FIXED-LEN RECORDS SEE IF ALL CHARS ARE NULL
RNER01: MOVE AC1,AC5 ; GET COPY SOURCE PTR
MOVE AC0,AC3 ; GET COUNT OF CHARS IN REC
RNR01A: ILDB C,AC1 ; GET A CHAR
JUMPN C,RNER06 ; EXIT HERE IF NOT NULL
SOJG AC0,RNR01A ; LOOP
TLNN FLG,RANFIL ; NULL RECORD,SKIP IF RANDOM FILE
MOVE AC5,AC1 ; RESET AC5 TO NEXT RECORD FOR SEQ
;GOT A NULL RECORD SEE WHAT TO DO WITH IT
RNRNUL: TXNE AC16,V%STRT ; SKIP IF NOT START
JRST STRT.0 ; BACK TO START WITH NO FIND
SKIPN NRSAV. ; IF WE ALREADY GOT START OF NULL STRING
SKIPN AC3,D.LBN(I16) ; OR IF NOT AN IO FILE
JRST RNER02 ; BRANCH
CAMLE AC3,D.CBN(I16) ; IF THIS IS NOT THE LAST BLOCK,
JRST RNER02 ; DONT PUSH
MOVE AC0,[-5,,NRSAV.-1]; SAVE POINTERS TO LAST REAL RECORD
PUSH AC0,R.BPNR(I12) ;
PUSH AC0,FS.RN ;
PUSH AC0,D.RP(I16) ;
PUSH AC0,D.RCL(I16) ;
RNER02: SKIPL D.FCPL(I16) ; SKIP IF NULL BLOCK (SET AT RNIN1A)
JRST RNER2A ; JUMP AHEAD IF NON-NULL BLOCK
; IN NULL CASE SET UP SO AS TO
; SKIP AHEAD TO THE NEXT BLOCK
MOVE D.RCL(I16) ; GET NUMBER RECORDS LEFT IN BLK
ADDM AC0,D.RP(I16) ; ADVANCE RECORD COUNTERS
ADDM AC0,FS.RN ; SO AS TO INDICATE BEGINING OF NEXT BLK
SETZM D.RCL(I16) ; CLEAR THIS TO GET NEXT BLK
RNER2A: LDB AC3,F.BMRS ; RESTORE RECORD SIZE
TLNN FLG,RANFIL ; SKIP IF RANDOM FILE
JRST RNER2B ; ELSE, NULL RECORD IN SEQUENTIAL FILE
HRRZ AC0,D.WPR(I16) ; GET WORDS PER RECORD
ADD AC5,AC0 ; ADVANCE AC5 TO NEXT RECORD
RNER03: JUMPN AC4,RNER05 ; JUMP IF ACT-KEY NON-ZERO
MOVEM AC5,R.BPNR(I12) ; SAVE AS PTR TO NEXT REC
JRST RANDOM ; ACT-KEY = 0 SO GET NEXT RECORD
RNER2B: EXCH AC5,R.BPNR(I12) ; NULL RECORD - GET NEXT
MOVEM AC5,R.BPLR(I12) ; UPDATE BYTE-PTRS
AOS D.RP(I16) ; COUNT THIS RECORD
AOS FS.RN ; HERE TOO
JRST SQIO2 ; GET NEXT RECORD
RNER05: AOS (PP) ; GIVE HIM AN INVALID KEY RETURN
MOVEI AC1,FS%23 ; READ INVALID KEY
MOVEM AC1,FS.FS ; LOAD FILE-STATUS
JRST RNER40 ; EXIT
;RESTORE THE NULL CHARS IF ANY
RNER06: TXNE AC16,V%STRT ; SKIP IF NOT START
JRST RNRSTT ; START, GO ON WITHOUT FINISHING READ
SETZM NRSAV. ; ZERO WHEN REAL REC IS FOUND
ILDB C,AC5 ; REGET FIRST CHAR
JRST RNER21 ; NOW GET REST OF RECORD
;HERE IF GOT NON-NULL FOR START
RNRSTT: SETOM R.STRT(I12) ; INDICATE START DONE
JRST RNER40 ; RETURN TO USER (EVENTUALLY)
;READ - VAR-LEN RECORDS SO CHECK THE SIZE
RNER10: PUSHJ PP,RNDW ; GET RDW INTO AC1 AND AC0
JUMPN AC1,RNR10A ; JUMP IF NOT NULL RECORD
TLNN FLG,RANFIL ; SKIP IF RANDOM FILE
JRST RNULER ; ELSE,ERROR NULL RECORD IN SEQ VARIABLE FILE
JRST RNRNUL ; NOW GO CHECK WHAT TO DO WITH NULL
RNR10A: TXNE AC16,V%STRT ; SKIP IF NOT START
JRST RNRSTT ; JUMP IF START
CAIL AC3,-4(AC1) ;[613] WILL IT FIT INTO RECORD AREA
JRST RNR10B ;[613] YES
PUSHJ PP,ERRMR1 ;[613] NO - COMPLAIN
;[613] HERE IF USE PROCEDURE IGNORED ERROR
OUTSTR [ASCIZ/%Record length field larger than FD maximum, assuming max.
/]
JRST RNR10C ;[613] AND CONTINUE USING MAX RECORD SIZE
RNR10B: LDB AC3,F.BLRS ;LOAD MINIMUM SIZE
CAMG AC3,-4(AC1) ;IS RECORD LESS THAN MINIMUM
JRST RNR10D ;YES
PUSHJ PP,ERRLR2 ;ERROR MESSAGE
OUTSTR [ASCIZ/%Record length field smaller than FD minimum.
/]
RNR10D: MOVEI AC3,-4(AC1) ;[613] USE ACTUAL ,NOT MAX SIZE
RNR10C: ADDI AC5,1 ;[613] ADVANCE AC5 PAST RDW
;READ - MOVE RECORD FROM BUFFER TO RECORD AREA
RNER20: ILDB C,AC5 ; GET CHAR
RNER21: XCT AC10 ; CONVERT
IDPB C,AC6 ; PUT CHAR
SOJG AC3,RNER20 ; LOOP
JRST RNER40 ; EXIT
;WRITE - MOVE RECORD AREA TO BUFFER
RNER30: MOVE AC10,D.WCNV(I16); SETUP THE CONVERSION INST
JUMPGE FLG1,RNR30A ; JUMP IF FIXED LEN RECORDS
PUSHJ PP,RNDW ; GET RDW INTO AC1
JUMPN AC1,RNR30C ; IT WILL BE 0 IF WE ARE APPENDING
TXNE AC16,V%DLT!V%RWRT ;DELETE OR REWRITE?
JRST RNDLER ;YES, ERROR NULL RECORD
PUSHJ PP,MAKRDW ; GO WRITE AN RDW
JRST RNER32 ; GO WRITE RECORD
MAKRDW: HRLZI AC1,4(AC3) ; SO MAKE A RDW
MOVNI AC0,4(AC3) ; NEGATE THE COUNT
ROT AC1,11 ; HI-BITS FIRST
IDPB AC1,AC5 ;
ROT AC1,11 ; LO-BITS NEXT
IDPB AC1,AC5 ;
SETZ AC1, ; THEN SOME NULLS
IDPB AC1,AC5 ;
IDPB AC1,AC5 ;
POPJ PP, ; RETURN
;CHECK FOR NULL RECORD ERRORS
RNR30A: PUSH PP,AC5 ;[1006] [700] SAVE DEST POINTER
PUSH PP,AC3 ;[1006] [700] AND BYTES/REC
RNR30D: ILDB AC1,AC5 ;[1006] [700] GET A BYTE
SKIPN AC1 ;[1006] [700] CONTINUE WHEN NON-NULL FOUND
SOJG AC3,RNR30D ;[1006] [700] OR WHEN NO BYTES LEFT
POP PP,AC3 ;[1006] [700] RESTORE BYTES/REC
POP PP,AC5 ;[1006] [700] AND DEST POINTER
JUMPE AC1,RNR30B ; SKIP AHEAD IF NULL RECORD
PUSHJ PP,WRTNUL ; GO CHECK FOR RANDOM WRITE TO NON-NULL REC
; DOESN'T RETURN IF ERROR
JRST RNER33 ; OK, GO DO IT
RNR30B: TXNE AC16,V%WRIT ; IS THIS WRITE?
JRST RNR33A ; YES, ALL OK GO ON
JRST RNDLER ; NO,TROUBLE-REWRITE OR DELETE WITH NULL REC
RNR30C: PUSHJ PP,WRTNUL ; GO CHECK FOR RANDOM WRITE TO NON-NULL REC
; DOESN'T RETURN IF ERROR
RNER31: TXNE AC16,V%DLT ;DELETE?
JRST RNRDLV ;YES, JUMP
CAIN AC1,4(AC3) ; SIZE OF EXISTING RECORD SAME AS NEW?
AOJA AC5,RNER32 ; SIZES EQUAL,GO WRITE RECORD
; AFTER ADANCING AC5 PAST RDW
LDB AC1,F.BMRS ; GET MAXIMUM RECORD SIZ
; ,RANDOM SPACED BY MAX REC SIZE
CAIGE AC1,4(AC3) ; WILL NEW RECORD FIT IN OLD PLACE?
JRST RERE5 ; NO,SIZE ERROR
PUSHJ MAKRDW ; YES,MAKE NEW RDW
RNER32:
RNER33: TXNE AC16,V%DLT ;DELETE?
JRST RNERDL ;YES, JUMP
RNR33A: ILDB C,AC6 ; GET CHAR
XCT AC10 ; CONVERT
IDPB C,AC5 ; PUT CHAR
SOJG AC3,RNR33A ; LOOP
SETOM R.DATA(I12) ; NOTE ACTIVE DATA IN BUFFER
SETOM R.WRIT(I12) ; AND WRITE WAS LAST
;FINISH UP AND EXIT
RNER40: TXNN AC16,V%DLT+V%RWRT ; IS THIS DELETE OR RERIT?
JRST RNR40X ; NO, CURRENT POSITION RESET
LDB AC0,F.BFAM ; GET ACCESS MODE
JUMPN AC0,RNR40B ; IF NOT SEQ ACCESS JUMP PAST POSITION CHANGE
RNR40X: TLNN FLG,RANFIL ; RANDOM FILE?
JRST RNR40A ; NO
HRRZ AC5,D.WPR(I16) ; YES,GET DISTANCE TO NEXT RECORD
ADD AC5,R.BPNR(I12) ; THEN PTR IT TO NEXT RANDOM RECORD
RNR40A: EXCH AC5,R.BPNR(I12) ; UPDATE NEXT-RECORD AND
MOVEM AC5,R.BPLR(I12) ; LAST-RECORD POINTERS
RNR40B: TLNN FLG,RANFIL ; RANFIL FILE?
JRST RANXI0 ; NO - SEQIO FILE!
TXNN AC16,V%READ ; READ OR ?
JRST RANXI2 ; WRITE
JRST RANXI1 ; READ
;RESET RDW WORD TO INDICATE NULL RECORD
RNRDLV: MOVE AC1,AC5 ;GET POINTER TO RDW
SETZ C, ;GET NULL
IDPB C,AC1 ;ZERO FIRST BYTE
IDPB C,AC1 ;AND SECOND
AOJA AC5,RDERD1 ; ADVANCE AC5 TO RECORD START (AFTER RDW)
;GO DELETE RECORD
;DELETE A FIXED LENGTH RECORD
;FIRST CHECK THAT THERE IS NOT A NULL RECORD ALREADY THERE
RNERDL: MOVE AC1,AC5 ;GET BUFFER POINTER
ILDB C,AC1 ;GET A CHAR
JUMPE C,RNDLER ;ERROR, NULL RECORD
;NOW DELETE WHAT IS THERE
RDERD1: SETZ C, ;SET NULL CHAR
IDPB C,AC5 ;DELETE ONE CHAR
SOJG AC3,.-1 ;LOOP TILL ALL GONE
SETOM R.DATA(I12) ;NOTE ACTIVE DATA
SETOM R.WRIT(I12) ;AND NOT LAST READ
JRST RNER40 ;CLEAN UP
;RETURNS RECORD DESCRIPTOR WORD IN AC1 AND AC0 (NEGATED)
RNDW: MOVE AC0,AC5 ; GET BYTE-POINTER
ILDB AC1,AC0 ; GET HI-BITS
ILDB AC0,AC0 ; AND LO-BITS
LSH AC1,11 ; LINE EM UP
IOR AC1,AC0 ; MERGE EM
MOVN AC0,AC1 ; NEGATE EM
JRST RET.1 ; EXIT
; RNTBL IS USED TO FIND NTH RECORD IN LOGICAL BLOCK.
; DIVIDE REC-SIZE BY CHARS PER WORD - REMAINDER IS INDEX
; TABLE YIELDS BYTE-PTR TO FIRST CHAR OF NEXT RECORD
RNTBL: POINT 9,
POINT 9,,8
POINT 9,,17
POINT 9,,26
;MOVE THE RANDOM/IO RECORD AREA TO THE BUFFER AREA. ***RANXIT***
WRTNUL: TLNE FLG,RANFIL
TXNN AC16,V%WRITE ;RANDOM WRITE ?
POPJ PP, ; NO,OK- GO BACK
PUSHJ PP,SETS22 ;YES, THEN ITS ILLEGAL
MOVEM AC5,R.BPLR(I12) ; UPDATE LAST RECORD POINTER
TLNN FLG,DDMSIX ; DEVICE DATA MODE SIXBIT?
JRST WRTNLA ; NO
ADDI AC2,5+6 ; ROUND UP - ACCOUNT FOR HEADER WORD
IDIVI AC2,6 ; CONVERT TO WORDS
ADD AC5,AC2 ; UPDATE POINTER TO NEXT RECORD
JRST RANWRX ; FINISH
WRTNLA: ADD AC5,D.WPR(I16) ; POSITION TO NEXT RECORD
RANWRX: JUMPGE FLG1,.+2 ; SKIP IF NOT VAR-LEN EBCDIC
SUBI AC5,1 ; OTHERWISE BACK AC5 TO ADDRESS RDW
MOVEM AC5,R.BPNR(I12) ; UPDATE THE POINTER
HLLZS UOUT. ;[1151] CLEAR RIGHT HALF DUMP MODE IOWD
POP PP,(PP) ; KILL RETURN TO CALL POINT
JRST RET.3 ;BYPASS WRITE PARAMETERS & GIVE ERROR RETURN
RANWRZ: PUSHJ PP,WRTNUL ; CHECK FOR WRITE ON NULL (NO RETURN ON ERROR)
RANWR0: TXNE AC16,V%DLT ;[670] IF DELETE
JRST .+3 ;[670] SKIP BINARY CHECK
TLNE FLG,DDMBIN ;[670] IF BINARY,
JRST RAND7A ;[670] GO TO SPECIAL ROUTINE
TLNN FLG,DDMASC+DDMBIN ;[670] ASCII/BINARY SKIP - NO HEADER WORD
ADDI AC5,1 ;POINT AT DATA NOT RECSIZ
RANWRT: TXNE AC16,V%DLT ;DELETE?
JRST RANDEL ;YES, ITS SPECIAL
TXNN AC16,V%WRITE!V%WADV!V%RWRT ;IF IT'S WRITE,
JRST RANREA ;IT'S READ
TLNE FLG,DDMSIX ;SIXBIT STUFF IN THE BUFFER?
PUSHJ PP,RANSHF ;YES - MAKE SURE NEW RECORD FITS
TLNN FLG,CONNEC!DDMASC ;SKIP IF CONVERSION IS NECESSARY
JUMPGE FLG,RANRB ;SIXBIT, GO BLT THE DATA
MOVE AC10,D.WCNV(I16) ;SETUP AC10
TXNE AC16,V%WADV ; SKIP IF IT'S NOT WADV,
PUSHJ PP,WRTADV ; ELSE GO ADVANCE
TRNA ;NORMAL RETURN
AOS (PP) ;COPY END OF PAGE SKIP RETURN
RANWR1: ILDB C,AC6 ;PICK UP A CHARACTER
XCT AC10 ;CONVERT IF NECESSARY
IDPB C,AC5 ;DEPOSIT THE CHAR.
SOJG AC3,RANWR1 ;LOOP TILL A COMPLETE RECORD IS PROCESSED
JUMPGE FLG,RANWR2 ;JUMP,SIXBIT HAS NO "CRLF"
TXNN AC16,V%WADV ;[WADV] SKIP IF IT'S WRITE ADVANCE,
JRST RNWR2A ;[WADV] ELSE WRITE CR-LF
PUSHJ PP,WRTADV ; DO ADVANCING NOW
TRNA ;NORMAL RETURN
AOS (PP) ;COPY END OF PAGE SKIP RETURN
JRST RNWR2B ;[WADV] CONTINUE
;[WADV] NO ADVANCING SO GIVE JUST CR-LF FOR RANDOM WRITE
RNWR2A: ;[M1114]
TXNE AC16,V%RWRT ;[A1114] DOING REWRITE?
JRST RNWR2B ;[A1114] YES, DON'T PUT IN <CR><LF>
PUSHJ PP,RANCR ;[WADV] WRITE CR [M1114]
PUSHJ PP,RANLF ;[WADV] GIVE HIM A "LF"
RNWR2B: TLNE FLG,SEQFIL ;[WADV] SEQ FILE?
JRST RANWR3 ;[WADV] YES,DO NON-WORD ALIGNED CASE
RANWR2: ADDI AC5,1 ; ADVANCE NXT-REC PRT TO NEXT FREE WORD
RNWR2X: SETOM R.DATA(I12) ;THERE IS ACTIVE DATA IN THE BUFFER
SETOM R.WRIT(I12) ;THE LAST COBOL UUO WAS A WRITE
JRST RANXIT ; ADVANCE NXT-REC PTR AND TAKE STANDARD EXIT
RANWR3: SETOM R.DATA(I12) ;BUFFER DIRTY
SETOM R.WRIT(I12) ;WRITE LAST I-O
;[1023] Test is taken out.
;[1023] TXNE AC16,V%RWRT ; IS THIS RERIT?
;[1023] JRST RANXI0 ; YES,SKIP CURRENT POSITION RESET
;[1023] To update pointer
EXCH AC5,R.BPNR(I12) ;UPDATE NXT REC PTR
MOVEM AC5,R.BPLR(I12) ;UPDATE LAST REC PTR
JRST RANXI0 ;FINISH AND EXIT
RANDEL: TLNN FLG,DDMSIX ;SIXBIT?
JRST RANDLA ;NO, ASCII
HRRZ AC3,-1(AC5) ;GET THE RECORD SIZE
JUMPE AC3,RNDLER ;NO RECORD--SO INVALID KEY
SETZ AC3, ;NO DATA JUST HEADER
PUSHJ PP,RANSHF ;MOVE EXISTING RECORDS DOWN
MOVE AC0,R.BPNR(I12) ;[1035] CURRENT RECORD
MOVEM AC0,R.BPLR(I12) ;[1035] LAST RECORD
HRRI AC0,(AC5) ;[1035] ADR OF 1ST WORD OF NEXT RECORD
MOVEM AC0,R.BPNR(I12) ;[1035] BP TO NEXT RECORD
SETOM R.DATA(I12) ;[1035] THERE IS ACTIVE DATA IN BUFFER
SETOM R.WRIT(I12) ;[1035] THE LAST COBOL UUO WAS A WRITE
AOJA AC5,RANXI0 ;[1035] UPDATE THE RECORD POINTER & SIGNAL ACTIVE DATA
RANDLA: HRRZ AC1,AC5 ; GET ADR OF FIRST REC WORD
JUMPE AC2,RNDLER ;[670] NULL RECORD, SO INVALID KEY RETURN
TLNE FLG,DDMBIN ;[670] IF BINARY,
JRST RAND7A ;[670] GO TO SPECIAL ROUTINE
LDB AC10,F.BMRS ; GET MAX-RECORD SIZE
ADDI AC10,2+4 ; INCLUDE CRLF AND ROUND UP
IDIV AC10,D.BPW(I16) ; CONVERT TO REC SIZE IN WRDS
ADDI AC5,(AC10) ; POINT BYTE-PTR AT NEXT RECORD
HRL AC1,AC1 ; MAKE A BLT XWD
SETZM (AC1) ; ZERO THE FIRST RECORD WORD
ADDI AC1,1 ; NOW ITS A BLT XWD
HLRZ AC0,AC1 ; GET ADR OF FIRST REC WORD
CAIGE AC0,-1(AC5) ; SKIP BLT IF REC ONLY 1 WRD
BLT AC1,-1(AC5) ; CLEAR THE RECORD
JRST RNWR2X ; FINISH UP
RNDLER==RANDO3 ;[601] EXIT WITH INVALID KEY
;MOVE THE RANDOM/IO BUFFER AREA TO THE RECORD AREA. ***RANXIT***
RANREA: TXNN AC16,V%STRT ;JUST DOING START?
JRST RNREA0 ; NO, CONT
SETOM R.STRT(I12) ;YES, SET FLAG
TLNE FLG,DDMSIX ;SIXBIT STUFF IN THE BUFFER?
SUBI AC5,1 ; YES, ADDRESS HEADER COUNT
JRST RANXIT ;AND EXIT
RNREA0: TLC FLG,DDMASC+SEQFIL ;SEQ ASCII FILE?
TLCN FLG,DDMASC+SEQFIL ;IFSO
JRST RANRE5 ;DO NON-WORD ALIGNED CASE
MOVE AC1,AC3 ;SAVE MAX RECORD SIZE IN CHARS
TLNE FLG,DDMSIX ;IF A SIXBIT FILE
HRRZ AC3,-1(AC5) ; USE THE ACTUAL SIZE
MOVEM AC3,D.CLRR(I16) ;SAVE LENGTH OF REC TO BE READ
TLNN FLG,CONNEC!DDMASC ;SKIP IF CONVERSION IS NECESSARY
JUMPGE FLG,RANBR ;SIXBIT, GO BLT THE DATA
MOVE AC0,AC3 ;SAVE ACTUAL RECORD SIZE
MOVE AC10,D.RCNV(I16) ;SETUP AC10
HRRZ AC2,AC5 ;SAVE RECORD ORIGIN
RANRE0: ILDB C,AC5 ;PICK UP A CHARACTER
XCT AC10 ;CONVERT IF NECESSARY
JUMPL C,RANRE0 ;IGNORE LEADING EOL CHARS
JUMPG C,RANRE1 ;[300] IF NOT NULL , CONTINUE
SOJG AC3,RANRE0 ;[300] IF MORE CHARS. THEN LOOP
;[1013] JUMPE AC4,RANDOM ;[300] JUMP IF SEQ
JUMPN AC4,RANREN ;[1013] IF SEQUENTIAL
MOVE AC5,D.WPR(I16) ;[1013] ADD WORDS/RECORD TO BYTE PTR
ADDB AC5,R.BPNR(I12) ;[1013] SO IT POINTS TO NEXT RECORD
JRST RANDOM ;[1013] AND TRY AGAIN
RANREN: MOVEI AC1,FS%23 ;[1013] READ INVALID KEY
MOVEM AC1,FS.FS ; LOAD FILE-STATUS
AOS (PP) ;[300] SET UP SKIP RETURN
JRST RANRE2 ;[300] GO SET FLAGS
RANRE1: IDPB C,AC6 ;DEPOSIT INTO RECORD AREA
SOJE AC3,RANRE3 ;EXIT AFTER PROCESSING THE RECORD
ILDB C,AC5 ;GET NEXT CHAR
XCT AC10 ;CONVERT IF NECESSARY
JUMPGE C,RANRE1 ;LOOP IF NOT AN EOL CHAR
RANRE3: JUMPL C,RANRE4 ;ASCII AND NEEDS FILL
JUMPL FLG,RANRE2 ;ASCII NO FILL REQUIRED
SUB AC1,AC0 ;SIXBIT - HOW MUCH FILL?
JUMPE AC1,RANRE2 ;JUMP IF NONE
MOVE AC3,AC1 ;
JRST .+3 ;SKIP PAST D.CLRR UPDATE
RANRE4: SUB AC0,AC3 ;SET AC0 TO SIZE READ
MOVEM AC0,D.CLRR(I16) ;SAVE SIZE ACTUALLY READ
MOVEI C," " ;ASCII SPACE
TLNN FLG,CDMASC ;ASCII?
MOVEI C,0 ;NO, SIXBIT SPACE
IDPB C,AC6 ;FILL OUT RECORD
SOJG AC3,.-1 ;WITH SPACES
ADDI AC5,1 ; ADVANCE NXT REC PTR
RANRE2: JUMPGE FLG,RNRE2A ; JUMP IF FILE NOT ASCII
ADD AC2,D.WPR(I16) ; POINT TO FIRST WRD OF NEXT REC
SKIPA AC5,AC2 ; PUT IT IN AC5
; SKIP,FINISH AND EXIT
; HERE IF NON-ASCII READ, ADVANCE PTR AC5 TO NEXT WORD
RNRE2A: ADDI AC5,1 ; ADVANCE NEXT RECORD PTR AND CONT
RNRE2B: SETZM R.WRIT(I12) ;THE LAST COBOL UUO WAS A READ
JRST RANXIT ; TAKE NORMAL RANDOM EXIT
; HERE FOR SEQ-IO READ. CHECK FOR NULL RECORD,
; IFSO , COUNT IT AS REC FOR LOG-BLK AND START WITH NEXT
; WHEN REAL RECORD START IS FOUND , READ REC.
RANRE5: MOVE AC10,D.RCNV(I16) ;GET CONVERSION INSTR
RANRE6: SOJL AC3,RANRE9 ;CNT CHAR,JUMP END OF REC
RANRE8: ILDB C,AC5 ;GET CHAR
CAIE C,$CR ;[1031] EXCLUDE <CR> AND <LF> WHEN
CAIN C,$LF ;[1031] DECREMENTING THE CHARACTER COUNT
JRST RANRE8 ;[1031]
XCT AC10 ;CONVERT
JUMPLE C,RANRE6 ;SKIP LEAD NULL AND EOR CHARS
JRST RANRE7 ;GOT REAL CHAR,GET REC
; NULL RECORD FOUND, COUNT THIS ONE AND GET START OF NEXT
RANRE9: SKIPE D.RCL(I16) ;LAST REC IN LBLK?
JRST RANR12 ; NO
MOVE AC1,D.LBN(I16) ; YES,GET LAST LBLK #
CAMLE AC1,D.CBN(I16) ;LAST LBLK?
JRST RANR10 ; NO,GET NEXT LBLK
TLO FLG,ATEND ; YES,SET ATEND
SETOM R.WRIT(I12) ;SET NO READ LAST I-O
PUSHJ PP,SETS10 ;SET NO NEXT REC STATUS
JRST RANXI0 ;EXIT WITH ATEND SKIP
RANR10: HRRZ AC1,D.BPL(I16) ;GET BUFF/LBLK
ADD AC1,D.CBN(I16) ;INDICATE CURRENT BUF #
PUSHJ PP,RANIN ;DO INPUT,WRITE IF BUF DIRTY
JRST RANR11 ;SUCCESS,CONT
OUTSTR [ASCIZ/?EOF in RANRE5, internal error./] ;EOF
JRST KILL. ;COMPLAIN AND EXIT
RANR11: MOVE AC5,R.BPNR(I12) ;SET NEXT REC PTR
RANR12: SOS D.RCL(I16) ;CNT THIS REC
LDB AC3,F.BMRS ;SET MAX REC SIZE
MOVE AC10,D.RCNV(I16) ;GET CONVERSION INSTR
JRST RANRE8 ;CONT SCAN FOR REC
;FIRST BACK UP ONE CHAR
RANRE7: TXNN AC16,V%DLT+V%RWRT ; IS THIS DELETE OR RERIT?
JRST RANR7R ; NO, CURRENT POSITION RESET
LDB AC0,F.BFAM ; GET ACCESS MODE
JUMPN AC0,RNRE7A ; IF NOT SEQ ACCESS SKIP POSITION CHANGE
RANR7R: MOVE AC1,AC5 ; GET COPY CURRENT POS PTR
SUBI AC1,1 ; BACK TO PREV. WORD
IBP AC1 ; SKIP AHEAD
IBP AC1 ; SKIP AHEAD
IBP AC1 ; SKIP AHEAD
IBP AC1 ; SKIP AHEAD
MOVEM AC1,R.BPLR(I12) ; SET LAST PTR TO CHAR JUST
; BEFORE REC START
RNRE7A: LDB AC3,F.BMRS ;GET MAX REC SIZE
MOVE AC0,AC3 ;SAVE MAX REC SIZE
MOVEM AC0,D.CLRR(I16) ;SAVE HERE TOO
RANR13:
IDPB C,AC6 ;PUT CHAR
SOJE AC3,RNR13A ;CNT CHAR,JUMP IF ALL MOVED
ILDB C,AC5 ;GET ANOTHER
XCT AC10 ;CONVERT
JUMPGE C,RANR13 ;LOOP TIL EOR
JUMPLE AC3,RANR14 ;REC FILLED? JUMP IF SO
; FILL END OF RECORD WITH BLANKS
SUB AC0,AC3 ;GET SIZE ACTUALLY READ
MOVEM AC0,D.CLRR(I16) ;UPDATE CHAR LENGTH OF REC READ
MOVEI C," " ; NO, GET BLANK
XCT AC10 ;[1130]CONVERT
IDPB C,AC6 ; WRT BLANK IN REC
SOJG AC3,.-1 ; BLANK FILL REC
JRST RANR14 ; FIN
; REC FILLED , CHECK FOR SCAN TO EOR CHAR
RNR13A: HRRZ AC1,D.RFLG(I16) ; GET STANDARD ASCII FLAG
TRNE AC1,SASCII ; SKIP IF NOT STANDARD ASCII
JRST RANR14 ; ELSE SKIP EOR SCAN
MOVE AC1,D.RCL(I16) ; GET RECS LEFT IN LOG-BLK
SOJLE AC1,RANR14 ; IS THIS LAST RECORD IN LOG-BLK?
; YES, JUMP ,DON'T BOTHER WITH EOR SCAN
; NO, CONT EOR SCAN
;[1024] This patch is necessary for the last block of a file.
MOVE AC1,D.LBN(I16) ;[1024] GET LAST BLOCK NO.
CAME AC1,D.CBN(I16) ;[1024] SAME AS CURRENT BLOCK?
JRST RNR13D ;[1024] NO, SKIP CALCULATION
PUSH PP,AC5 ; SAVE CURRENT POSITION INCASE WE DON'T FIND EOR
HLRZ AC1,D.BL(I16) ; GET POINTER TO IOWD
MOVE AC1,(AC1) ; GET IOWD
HLRO AC0,AC1 ; GET NO. OF WORDS (NEGATIVE)
MOVNS AC0 ; POSITIVE WORDS
IMUL AC0,D.BPW(I16) ; BYTES IN BUFFER
SUBI AC5,(AC1) ; NO. OF FULL WORDS USED + PARTIAL LAST WORD
HRRZ AC1,AC5
IMUL AC1,D.BPW(I16) ; CHARACTERS USED
TRNA ; NOW ACCOUNT FOR UNUSED CHAR IN PARTIAL WORD
IBP AC5
TLNE AC5,760000 ; ALL BYTES USED?
SOJA AC1,.-2 ; NOT YET
MOVNS AC1,AC1
ADD AC1,AC0 ; GET NUMBER OF UNUSED CHAR IN BUFFER
MOVE AC5,(PP) ; RESTORE INPUT BYTE POINTER
RNR13B: ILDB C,AC5 ; GET A CHAR
XCT AC10 ; CONVERT IT
JUMPL C,RNR13C ; FOUND AN EOR CHAR
SOJG AC1,RNR13B ; NOT FOUND YET
POP PP,AC5 ; RESTORE PREVIOUS POINTER
JRST RANR14
RNR13C: POP PP,AC1 ; CLEAN UP STACK
JRST RANR14 ;[1024] CONT
RNR13D: ILDB C,AC5 ;[1024] GET A CHAR
XCT AC10 ;[1024] CONVERT IT
JUMPGE C,RNR13D ;[1024] SCAN TO EOR CHAR
RANR14: TXNN AC16,V%DLT+V%RWRT ; IS THIS DELETE OR RERIT?
JRST RNR14A ; NO, CURRENT POSITION RESET
LDB AC0,F.BFAM ; GET ACCESS MODE
CAIN AC0,%FAM.S ; IF NOT SEQ ACCESS SKIP POSITION CHANGE
RNR14A: MOVEM AC5,R.BPNR(I12) ;UPDATE NEXT REC PTR
SETZM R.WRIT(I12) ;READ WAS LAST I-O
JRST RANXI0 ;FINISH AND EXIT
;SETUP FLAG WORDS AND EXIT. ***WRTRE7***
RANXIT: TXNN AC16,V%DLT+V%RWRT ; IS THIS DELETE OR RERIT?
JRST RNXITA ; NO, CONT
LDB AC0,F.BFAM ; GET ACCESS MODE
CAIE AC0,%FAM.D ;[1077] IF DYNAMIC, COULD NEED SEQ POINTERS
JUMPN AC0,RANXI0 ; IF NOT SEQ ACCESS SKIP POSITION CHANGE
RNXITA: MOVE AC0,R.BPNR(I12) ; CURRENT RECORD
MOVEM AC0,R.BPLR(I12) ; LAST RECORD
HRRI AC0,(AC5) ; ADR OF 1ST WRD OF NEXT ASCII REC
MOVEM AC0,R.BPNR(I12) ;BP TO NEXT RECORD
RANXI0:
TLNE FLG,RANFIL ;[273] IF A RANDOM FILE
JRST RANXI1 ;[273] ZERO ATEND FLAG
TXNN AC16,V%READ ;SKIP IF A READ
JRST RANXI2 ;WRITE HAS NO ATEND SKIP EXIT
TLNN FLG,ATEND ;SKIP IF ATEND
RANXI1: TLZE FLG,ATEND ;ZERO THE ATEND FLAG
JRST RANXI4 ;HERE ON ATEND
RANXI2:
TLNE FLG,RANFIL ;[1065]IF A RELATIVE FILE
SKIPN F.WSMU(I16) ;[1065] AND SMU OPTION 1 IN EFFECT
JRST RNXI0A ;[1065]NOT EITHER (CAN BE NOT BOTH)
TXNN AC16,V%RNXT ;[1065]AND READ NEXT
JRST RNXI0A ;[1065] IS NOT
MOVE AC2,SU.T1## ;[1065]GET RRT ENTRY ADDR SAVED BY SU.XX ROUTINE
HLLZ AC3,1(AC2) ;[1065] IS RETAIN NEXT
TLNN AC3,400000 ;[1065] FLAG ON?
JRST RNXI0A ;[1065] NO.
MOVE AC1,F.RACK(I16) ;[1065]IF SO, WE NEED TO GET
MOVE AC3,(AC1) ;[1065] THE KEY AND
MOVEM AC3,3(AC2) ;[1065] PUT IT IN THE RRT ENTRY.
RNXI0A: ;[1065]
MOVEM FLG,F.WFLG(I16) ;SAVE FLAGS
HLLM FLG1,D.F1(I16) ;SAVE MORE FLAGS
HLLZS UOUT. ;ZERO THE RIGHT HALF
HLLZS UIN. ; IOWD POINTER
;[1064] SKIPE F.WSMU(I16) ; SIMULTANEOUS UPDATE ?
;[1064] PUSHJ PP,LRDEQX## ; YES
TXNN AC16,V%DLT+V%RWRT ; IS THIS DELETE OR RERIT?
SETZM R.DLRW(I12) ; NO,CLEAR DEL/RWT SAVE BLK NUM
TLNE FLG,IOFIL ;BL; [622] IF THIS IS AN IO FILE
TXNN AC16,V%WRIT ;BL; ARE WE WRITING?
JRST WRTRE7 ;BL; NO, DON'T UPDATE LAST BLOCK
MOVE AC0,D.CBN(I16) ; UPDATE THE LAST BLOCK NUMBER
CAMLE AC0,D.LBN(I16) ; IF CURRENT BN IS GT LAST BN
MOVEM AC0,D.LBN(I16) ; SAVE IT AS LBN
JRST WRTRE7 ;EXIT TO USER
RANXI4: TLNE FLG,RANFIL ;RANDOM FILE?
SOS D.RCL(16) ;YES - DONT COUNT THIS RECORD
RANXI3: AOS (PP) ;SKIP EXIT
SETOM R.WRIT(I12) ;READ NOT SUCCESSFUL
MOVEI AC1,RDLAST
ANDCAM AC1,D.RFLG(I16) ;HERE ALSO
SKIPN AC1,FS.FS ; NO CHANGE IF NON ZERO
MOVEI AC1,FS%10 ; READ INVALID KEY
MOVEM AC1,FS.FS ; LOAD FILE-STATUS
JRST RANXI2 ;
RANXI8: PUSHJ PP, SETS23 ; REC NOT FOUND STATUS (23)
TXNN AC16,V%DLT+V%RWRT ; IS THIS DELETE OR RERIT?
JRST RNXI8A ; NO, CURRENT POSITION RESET
LDB AC0,F.BFAM ; GET ACCESS MODE
JUMPN AC0,RANXI1 ; IF NOT SEQ ACCESS SKIP POSITION CHANGE
RNXI8A: MOVE AC0,R.BPNR(I12) ;[273] KEEP THE RECORD POINTERS
MOVEM AC0,R.BPLR(I12) ;[273] UP TO DATE
SKIPE NRSAV.+4 ; EXIT IF ACTUAL KEY NOT SAVED
TXNN AC16,V%STRT ; SKIP IF START FAILED
JRST RANXI1 ; ELSE EXIT
MOVE AC0,[-5,,NRSAV.+3]; IT IS SO BACK UP TO
POP AC0,D.RCL(I16) ; THE RECORD POSITION
AOS D.RCL(I16) ;
POP AC0,D.RP(I16) ; JUST AFTER THE LAST
POP AC0,FS.RN ; REAL RECORD SO APPEND
POP AC0,R.BPLR(I12) ; WILL FIND THE RIGHT RECORD SLOT
MOVE AC0,R.BPLR(I12) ; NOW, MAKE THE NEXT RECORD SLOT
MOVEM AC0,R.BPNR(I12) ; BE THE SAME AS THE LAST RECORD SLOT
SETZM NRSAV. ; ZERO NULL-REC-IN-LAST-BLOCK FLAG
SETZM R.WRIT(I12) ; ZERO THE WRITE FLAG
HRRZ AC4,F.RACK(I16) ;GET POINTER TO RELATIVE KEY
MOVE AC2,NRSAV.+4 ; GET KEY
SKIPE AC4 ; SKIP IF NO KEY POINTER
MOVEM AC2,(AC4) ; SAVE IT FOR INVALID KEY CONDITION
JRST RANXI1 ;[273]
;SIXBIT: BLT THE RECORD TO/FROM THE BUFFER AREA.
RANBR: EXCH AC5,AC6 ;GO THE OTHER WAY
RANRB: HRL AC5,AC6 ;FROM,,TO
HRRZM AC5,TEMP. ;
TXNE AC16,V%READ ;SKIP IF NOT READ
HLRZM AC5,TEMP. ;BUFFER ORIGIN
MOVEI AC4,6 ;SIX PER WORD
RANBR1: IDIV AC3,AC4 ;CONVERT TO WORDS
JUMPE AC4,.+2 ;SKIP IF NO REMAINDER
ADDI AC3,1 ;ELSE ACCOUNT FOR IT
MOVE AC0,AC3 ;SAVE ACT SIZE FOR ZERO FILL
ADDM AC3,TEMP. ;NEXT RECORD
ADDI AC3,-1(AC5) ;UNTIL
TXNE AC16,V%DLT ;IS THIS DELETE??
SUBI AC3,1 ;YES, DO THIS TO MAKE UP FOR AC5=BUFF,,BUFF+1
;NOT AC5=REC,,BUFF
BLT AC5,(AC3) ;ZRAPPP!
MOVE AC5,TEMP. ;
TXNN AC16,V%READ ;SKIP IF IT'S A READ
JRST RANBR2 ;NOP, A WRITE
TLNE FLG,DDMBIN ;IS DEVICE BINARY?
JRST RNRE2B ;YES,NO FILL NEEDED,FINISH UP
ADDI AC1,5 ;GET MAX SIZE
IDIVI AC1,6 ; IN WORDS
SUB AC1,AC0 ;WHAT'S THE DIFFERENCE?
JUMPLE AC1,RNRE2B ; DONE IF THE SAME
SETZM 1(AC3) ;ZERO THE FIRST WORD
HRLI AC2,1(AC3) ;FROM
HRRI AC2,2(AC3) ;FROM , TO
ADDI AC1,(AC3) ;UNTIL
CAIL AC1,(AC2) ;DONE IF ONLY ONE WORD
BLT AC2,(AC1) ;FILL IN THE ZEROS
JRST RNRE2B ;
RANBR2: JUMPE AC4,RNWR2X ;EXIT HERE IF NO FILL REQUIRED
HRREI AC1,-6 ;ASSUME RECORD IS SIXBIT
TLNN FLG,CDMSIX ; IF NOT SIXBIT
HRREI AC1,-7 ; ITS ASCII
IMUL AC4,AC1 ;ZERO FILL THE LAST DATA WORD
SETO AC0, ;--
LSH AC0,(AC4) ;--
ANDCAM AC0,(AC3) ;DOIT
JRST RNWR2X ; TAKE NORMAL EXIT
;BINARY: BLT THE RECORD TO/FROM THE BUFFER AREA.
RANBIN: HRL AC5,FLG ;FROM RECORD TO BUFFER
HRRZM AC5,TEMP. ;SAVE BUFFER LOC
TXNN AC16,V%DLT ; IS THIS DELETE??
JRST RANBNA ; NO,GO ON
HRLS AC5 ; YES,SET SO IT WILL BLT TO ITSELF
SETZM (AC5) ; CLEAR FIRST WORD
ADDI AC5,1 ; SET TO BLT . TO .+1
RANBNA: TXNE AC16,V%READ ;IF READ,
MOVSS AC5 ; REVERSE THE DIRECTION OF BLT
LDB AC4,[POINT 2,FLG,14] ; GET CORE DATA MODE
HRRZ AC4,RBPTBL(AC4) ; GET CHARS PER WORD
JRST RANBR1
;ALL RANDOM/IO INPUTS ARE EXECUTED FROM HERE. OUTPUTS ARE
;EXECUTED ONLY WHEN THERE IS ACTIVE DATA IN THE BUFFER AND
;AND AN INPUT IS ABOUT TO OVERWRITE IT. THE LAST ACTIVE DATA
;IS CAUGHT BY THE CLOSE UUO. ***POPJ***
RANIN: TXNN AC16,V%DLT+V%RWRT ; IS THIS DELETE OR RERIT?
JRST RANI0A ; NO, RESET CURRENT BLK NUM
LDB AC0,F.BFAM ; GET ACCESS MODE
JUMPE AC0,RANI0A ; IF SEQ ACCESS SKIP THIS SAVE
MOVE AC0,D.CBN(I16) ; GET CURRENT BLK NUM
SKIPN R.DLRW(I12) ; DON'T RESET IF ALREADY SET
MOVEM AC0,R.DLRW(I12) ; AND SAVE IT FOR SEQ "CURRENT" POSITION
TRNA ; AND SKIP
RANI0A: SETZM R.DLRW(I12) ; CLEAR DEL/RERIT SAVE
SKIPGE R.DATA(I12) ;SKIP IF THERES NOTHING TO OUTPUT
PUSHJ PP,RANOUT ;
MOVEM AC1,D.CBN(I16) ;SAVE CURRENT PHYS BLOCK NUMBER
MOVEM AC1,FS.BN ;SAVE BLOCK-NUMBER
HLLZS D.IBL(I16) ;[475] TURN FLAG OF IN CASE
CAML AC1,D.LBN(I16) ;[475] IF WE ARE READING LAST BLOCK
HLLOS D.IBL(I16) ;[475] IT MAY BE A PART BLOCK REMEMBER
TLNN FLG,RANFIL ;SKIP THE USETI IF SEQIO
JRST RANI00 ;SKIP
PUSHJ PP,FUSI ; DO A FILOP. TYPE USETI
RANI00: HRRM AC12,UIN. ;DUMP MODE IOWD
LDB AC5,F.BBKF ;BLOCKING FACTOR
REPEAT 0,<
IFN ANS68,<
TXNN AC16,V%READ ;SKIP IF READ UUO
CAIE AC5,1 ;DONT INPUT IF BLOCKING-FACTOR = 1
>>
RANIN0: TLNN FLG,OPNIN!RANFIL ;DONT INPUT IF NOT OPEN FOR INPUT
JRST RANIN5 ; NORMAL RET
AOS D.IE(I16) ;COUNT INPUT EXECUTED
HRRZ AC10,D.IBL(I16) ;[475] SKIP IF WE ARE ABOUT TO READ LAST BLOCK
JUMPE AC10,RNIN0A ;[475] ELSE DON'T CLEAR
PUSH PP,AC4 ;SAVE AC4 FOR EBCDIC READ
PUSHJ PP,ZDMBUF ;[475] SO CLEAR BUFFER OF OLD GARBAGE
POP PP,AC4 ;GET BACK AC4
RNIN0A: XCT UIN. ;********************
JRST RANIN1 ;NORMAL RETURN
MOVEM AC2,TEMP.1 ;SAVE AC2
PUSHJ PP,READCK ; ERROR RETURN
RANIN1: SKIPA AC10,R.BPFR(I12);BYTE POINTER TO FIRST RECORD
JRST RANIN3 ;EOF WAS SEEN ;READI1 SKIP EXIT
TXNE AC16,V%DLT+V%RWRT ; IS THIS DELETE OR RERIT?
JRST RNIN1B ; IFSO SKIP NEXT REC RESET
MOVEM AC10,R.BPNR(I12);POINTER TO CURRENT RECORD
MOVEM AC5,D.RCL(I16) ;REMAINING RECORDS IN CURRENT BLOCK
RNIN1B: JUMPGE FLG1,RET.1 ; VAR-LEN RECS DROP THROUGH
HRRZ AC10,R.BPFR(I12); GET POINTER TO BDW
MOVS AC0,-1(AC10) ; GET BDW
JUMPN AC0,RNIN1A ; JUMP IF NOT NULL BLOCK
TXNN AC16,V%READ ; SKIP IF READ,WHEN D.FCPL WILL BECOME =-4
PUSHJ PP,MAKBDW ; CREATE BDW
RNIN1A: SUBI AC0,4 ; -4 FOR BDW ITSELF
MOVEM AC0,D.FCPL(I16) ; SAVE AS FREE CPL
POPJ PP,
;HERE ON END-OF-FILE
RANIN3: MOVE AC2,R.IOWD(I12) ;GET IOWD TO BUFFER
SKIPE 1(AC2) ; SKIP IF A 0 SEEN
JRST .+3 ;SOMETHING THERE
AOBJN AC2,.-2 ;LOOP UNTIL NON-ZERO WORD SEEN
JRST RANIN4 ; NOTHING WAS INPUT - IT IS REALLY EOF
MOVE AC2,TEMP.1 ;RESTORE AC2
TLZ FLG,ATEND ;YES, SO TURN OFF THE EOF
JRST RANIN1 ; AND MAKE BELEIVE IT DIDN'T HAPPEN
RANIN4: MOVE AC2,TEMP.1 ;RESTORE AC2
TXNN AC16,V%READ ;READ UUO?
TLZA FLG,ATEND ; WRITE UUO SO CLEAR "ATEND"
AOSA (PP) ; READ GETS A SKIP EXIT
JRST RANIN5 ; TAKE NORMAL RETURN
LDB AC4,F.BFAM ;GET FILE ACCESS MODE
TLNE FLG,RANFIL ; SEQUENTIAL FILE?
SKIPN AC4 ; [601] NO,ACTUAL-KEY 0?(FILE IS SEQ?)
JRST RANN4B ; SEQ FILE HERE
TXNN AC16,V%RNXT ; IS THIS READ NEXT?
JRST RANN4A ; [601] NO,"RECORD NOT FOUND" GOES HERE
RANN4B: PUSHJ PP,SETS10 ; [601] YES,SET NO NEXT RECORD
JRST RANIN5 ; [601] GO ON
RANN4A: PUSHJ PP,SETS23 ; [601] SET NO RECORD FOUND STATUS
;IF VAR LEN RECS MAKE A BLOCK DESCRIPTOR WORD
RANIN5: JUMPGE FLG1,RANIN1 ; JUMP IF FIXED LEN RECS
PUSHJ PP,MAKBDW ; MAKE BDW FOR NEW BLOCK
JRST RANIN1 ; CONTINUE WITH NORMAL RETURN
;ROUTINE TO MAKE BDW AT FIRST WORD IN BLK
MAKBDW: HRRZ AC10,R.BPFR(I12); GET POINTER TO BDW (POINTS AFTER BDW)
HRRZ AC0,D.TCPL(I16) ; GET BLOCK SIZE
ADDI AC0,4 ; PLUS 4 FOR BDW
MOVSM AC0,-1(AC10) ; SAVE AS BDW
POPJ PP, ; RETURN
;ALL RANDOM/IO OUTPUTS ARE EXECUTED FROM HERE. ***@POPJ***
RANOUT: SETZM R.DATA(I12) ;NOTE DATA WENT OUT
EXCH AC1,D.CBN(I16) ;NEXT BLOCK,,CURRENT BLOCK
MOVEM AC1,FS.BN ;SAVE FOR ERROR STATUS
PUSHJ PP,FUSO ; DO A FILOP. TYPE USETO
MOVE AC1,D.CBN(I16) ;NEXT BLOCK BECOMES CURRENT BLOCK
HRRM AC12,UOUT. ;DUMP MODE IOWD
JRST WRTOUT ;DO IT
;ZERO THE DUMP MODE BUFFER AREA
ZDMBUF: HLRO AC4,R.IOWD(I12) ;-LEN
HRR AC1,R.IOWD(I12) ;LOC-1
HRLI AC1,1(AC1) ;FROM
HRRI AC1,2(AC1) ;TO
SETZM -1(AC1) ;THE ZERO
MOVN AC4,AC4 ;LEN
ADDI AC4,-1(AC1) ;UNTIL
BLT AC1,(AC4) ;DOIT
POPJ PP,
RANLF: SKIPA C,[$LF] ;
RANCR: MOVEI C,$CR ;
IDPB C,AC5 ;
POPJ PP, ;
;IF ACCESS MODE IS SEQUENTIAL
; SET AC4 = 0 IF NO RELATIVE KEY
; ELSE SET AC4 TO NEXT RECORD AND UPDATE KEY
;IF ACCESS MODE IS RANDOM MAKE SURE KEY IS VALID (GREATER THAN 0)
;F.BFAM 0 = SEQUENTIAL, 1 = RANDOM, 2 = DYNAMIC
SETKEY: LDB AC1,F.BFAM ;GET ACCESS MODE
HRRZ AC4,F.RACK(I16) ;GET POINTER TO RELATIVE KEY
SKIPN AC2,AC4 ; SKIP IF KEY PTR EXISTS
JRST SETKE1 ; NO KEY PTR SO 0 KEY
SKIPN AC2,NRSAV.+4 ; GET SAVED KEY IF ANY
MOVE AC2,(AC4) ; GET KEY
SETKE1: MOVEM AC2,NRSAV.+4 ; SAVE IT FOR INVALID KEY CONDITION
JUMPE AC4,SETKSA ;NO KEY SPECIFIED, READ SEQUENTIALLY
TXC AC16,V%READ!V%RNXT ;READ NEXT RECORD?
TXCN AC16,V%READ!V%RNXT
JRST [SKIPL R.STRT(I12) ;YES
JRST SETKSA ;THEN ITS SEQUENTIAL
JRST .+1] ;UNLESS START WAS LAST IO
TXNE AC16,V%READ
TXNN AC16,V%STRT ;IS IT START?
JRST @[EXP SETKYS,SETKYR,SETKYD](AC1)
SKIPE (AC4) ; SKIP IF ZERO KEY VALUE
JRST SETKE2 ; NON ZERO, CONT
TXNN AC16,STA%EQ ; START = ?
JRST STKYRX ; YES,0 KEY VALUE (ERROR)
SETKE2: TXZN AC16,STA%GT ;GREATER THAN?
JRST @[EXP SETKSS,SETKYR,SETKYD](AC1)
TXO AC16,STA%NL ;YES, MAKE NOT LESS THAN
AOS (AC4) ;AND INCREMENT THE KEY
JRST @[EXP SETKSS,SETKYR,SETKYD](AC1)
;SEQUENTIAL
SETKSS: SKIPE AC4,(AC4) ;GET KEY FOR START
POPJ PP,
SETKYS: SKIPN R.BPLR(I12) ;FIRST TIME?
SETZM (AC4) ;YES, START AT FRONT OF FILE
TXNN AC16,V%DLT ;DELETING LAST RECORD READ?
SKIPE R.STRT(I12) ; OR LAST IO WAS A START
TRNA ;NO
AOSA (AC4) ;NO, INCREMENT KEY
SKIPA AC4,(AC4) ;YES
SETKSA: SETZ AC4, ;SIGNAL SEQUENTIAL
SETZM R.STRT(I12) ;ONLY ONCE
POPJ PP,
;RANDOM
SETKYR: SETZM R.STRT(I12) ;CLEAR LAST IO WAS START
SKIPE AC4,(AC4) ;RELATIVE KEY
POPJ PP, ; RETURN WITH KEY SET UP
STKYRX: POP PP,(PP) ;POP OFF RETURN ADR
TXNN AC16,V%READ!V%DLT ;INVALID-KEY EXITSKIP IF READ
AOS (PP) ;SKIP OVER THE OPERAND
PUSHJ PP,SETS24 ;BOUNDRY VIOLATION - LOAD FILE-STATUS
JRST RET.2 ; AND TAKE A SKIP EXIT ***ACP***
;DYNAMIC
SETKYD: JRST SETKYR ;SEQUENTIAL TAKEN CARE OF, MUST BE RANDOM
;HERE BEFORE WRITING A NEW RECORD
;MAKE THE OLD RECORD SIZE CONFORM TO NEW SIZE
RANSHF: CAMN AC2,AC3 ;ACTUAL-SIZE VS NEW-SIZE
POPJ PP, ;SKIP THIS MESS
MOVE AC4,D.RCL(I16) ;IF NO RECORDS FOLLOWING
JUMPE AC4,RANS09 ; DONE
MOVEI AC0,5(AC3) ;NEW SIZE
IDIVI AC0,6 ; IN WORDS
MOVEI AC1,5(AC2) ;ACTUAL SIZE
IDIVI AC1,6 ; IN WORDS
SUB AC0,AC1 ;NS - AS
JUMPE AC0,RANS09 ;SAME SIZE SO EXIT
;FIND THE LAST DATA WORD IN THIS LOGICAL BLOCK
MOVE AC10,AC1 ;SIZE OF THIS RECORD
MOVEI AC2,-1(AC5) ;ADR OF THIS RECORD'S HEADER WORD
RANS01: ADDI AC2,1(AC10) ;ADR OF NEXT HEADER WORD
HRRZ AC10,@AC2 ;SIZE OF NEXT RECORD IN CHARACTERS
ADDI AC10,5 ; --
IDIVI AC10,6 ; IN WORDS
SOJG AC4,RANS01 ;LOOP IF ANY MORE
ADDI AC2,(AC10) ;ADR OF LAST DATA WORD
HRRO AC10,AC5 ;ADR OF THE FIRST RECORD WORD
ADD AC10,AC1 ;ADR OF NEXT RECORD'S HEADER WORD
JUMPG AC0,RANS03 ;IF POSITIVE MAKE A LARGER HOLE
;NEGATIVE SO MAKE A SMALLER HOLE
HRLS AC10 ;ADR OF NEXT RECORD HEADER WORD
ADD AC10,AC0 ; PLUS THE DIFFERENCE
ADD AC2,AC0 ;THE BLT UNTIL POINTER
BLT AC10,(AC2) ;MOVE IT
SETZM 1(AC2) ;TERMINATE DATA
JRST RANS09
;POSITIVE SO MAKE A LARGER HOLE
RANS03: HRRZ AC4,AC2 ;ADR OF LAST DATA WORD
SUBI AC4,-1(AC10) ;NUMBER OF WORDS TO MOVE
HRR AC10,AC2 ;START WITH THE LAST DATA WORD
HRLI AC0,(POP AC10,(AC10))
HRLZI AC1,(SOJG AC4,AC0)
HRLZI AC2,(POPJ PP,)
PUSHJ PP,AC0 ;POP-POP-POP
RANS09: HRRZM AC3,-1(AC5) ;GIVE IT A HEADER WORD
HRRZ AC2,AC3 ;RESTORE AC2
POPJ PP,
;FORCE WRITE FOR SIMULTANEOUS UPDATE
FORCW.:: MOVE AC0,[FS.ZRO,,FS.FS] ; CLEAR FILE STATUS BLOCK
BLT AC0,FS.IF ; FOR POSSIBLE ERROR ACTION
PUSHJ PP,SETCN. ; SET UP CHANNEL NUMBER
MOVE FLG,F.WFLG(I16) ; JUST IN CASE OF ERRORS
MOVE AC1,D.CBN(I16) ; GET THE BLOCK NUMBER
HLRZ AC12,D.BL(I16)
PUSHJ PP,RANOUT ; GO WRITE IT OUT
SOS (PP) ; NORMAL RETURN
SOS D.OE(I16) ; DON'T COUNT THIS OUTPUT
HLLZS UOUT. ; CLEAR IOWRD PTR
SETZM R.DATA(I12) ; SET NO ACTIVE DATA FLAG
JRST RET.2 ; RETURN
;FORCE READ FOR SIMULTANEOUS UPDATE
FORCR.:: MOVE AC0,[FS.ZRO,,FS.FS] ; CLEAR FILE STATUS BLOCK
BLT AC0,FS.IF ;
MOVE FLG,F.WFLG(I16) ; GET FLG REGISTER
TLNE FLG,IDXFIL ;ISAM FILE?
JRST FORCRY ;JUMP IF FILE INDEXED
MOVE AC1,D.CBN(I16) ; GET BLOCK NUMBER
MOVEM AC1,FS.BN ; SAVE FOR ERROR ACTION
PUSHJ PP,SETCN. ; SET UP CHANNEL
HLRZ AC12,D.BL(I16)
HRRM AC12,UIN. ; SET IOWRD PTR
PUSHJ PP,FUSI ; DO A FILOP. TYPE USETI
XCT UIN. ; TO READ
JRST FORCRX ; NORMAL RETURN
PUSHJ PP,READCK ; ERROR RETURN (EOF?)
JRST FORCRX ; SHOULD NOT GET HERE
TLNN FLG,ATEND ; EOF GETS NORMAL RETURN
AOS (PP) ; ERROR GETS SKIP RET
FORCRX: HLLZS UIN. ; CLEAR THE IOWRD PTR
POPJ PP,
;ZERO THE ISAM BLOCK NUMBERS TO CAUSE FRESH INPUTS
FORCRY:
IFN ISTKS,<
HLRZ I12,D.BL(I16)
AOS INSSSS+15(I12)
>
HLRZ I12,D.BL(I16) ;ZERO POINTERS
HRRI AC1,USOBJ(I12)
HRLI AC1,(AC1)
ADDI AC1,1
SETZM -1(AC1)
BLT AC1,USOBJ+13(I12)
SETZM CNTRY(I12) ;[1027] CLEAR BUFFER ADDRESS
PUSHJ PP,VNDE1 ; READ FRESH COPY OF STATISTICS BLOCK
POPJ PP, ; NO NEW LEVELS EXIT
POPJ PP,
SUBTTL ISAM-CODE
;INDEX-SEQ READ
IREAD: TLZ FLG1,F1CLR ;[605] INITIALIZE FLG1 FOR ISAM FLAGS
PUSHJ PP,SETIC ;SET THE CHANNEL
HRR AC0,F.WBSK(I16)
HRRM AC0,GDPSK(I12)
AOS RWRSTA(I12) ;# OF READ/WRITE/REWRITES
TXNE AC16,V%STRT ;[605] SKIP IF NOT START
JRST ISTRT ;[605] START GOES HERE
PUSHJ PP,LVTST ;RECORD KEY = LOW-VALUES ?
JRST SREAD ;YES, SEQUENTIAL READ
; CLEAR SAVED NEXT RECORD POSITION FLAG
HRRZ AC0,D.RFLG(I16) ; GET SOME FLAGS
TRZ AC0,SAVNXT ; CLEAR FLAG FOR NXT REC POS SAVED
SKIPN SU.FRF ; IF NOT RETAIN FAKE READ
HRRM AC0,D.RFLG(I16) ; PUT IT BACK
SKIPLE SU.FRF ; Is this RETAIN del/rewrt?
PUSHJ PP,SVDLRW ; Yes, then try saving current position
PUSHJ PP,@GETSET(I12) ;ADJKEY OR GD67 OR FPORFP
PUSHJ PP,IBS ;LOCATE THE RECORD
IREAD1: SKIPN SU.FRF
JRST MOVBR ;JUMP IF NOT FAKE READ TO MOVE RECORD
IREADF: MOVE AC1,USOBJ(I12) ; FAKE READ - DONT TOUCH REC-AREA
MOVEM AC1,FS.BN ; JUST RETURN THE BLOCK NUMBER TO RETAIN
POPJ PP,
;[605] HERE IS THE START CODE FOR ISAM FILES.
ISTRT: PUSHJ PP,@GETSET(I12) ;[605] ADJKEY OR GD67 OR FPORFP
PUSHJ PP,IBS ;[605] LOCATE THE RECORD
;[605] IBS GIVES A SKIP RET FOR STRT
;[605] INVALID KEY CONDITIONS
JRST ISTRT0 ;[605] REC = RECORD KEY FOUND
TXNE AC16,STA%EQ ;[605] RECORD KEY = NOT FOUND
;[605] SKIP IF START AT .EQ. CURRENT RECORD
JRST ISTRT1 ;[605] START GT OR NOT.LS.
HRRZ AC0,D.RFLG(I16) ; GET SOME FLAGS
TRZE AC0,SAVNXT ; CLEAR FLAG FOR NXT REC POS SAVED
HRRM AC0,D.RFLG(I16) ; PUT IT BACK
PUSHJ PP,SETS23 ;[605] SET NO RECORD STATUS INVALID KEY
SKIPE F.WSMU(I16) ;[605] SIMULTANEOUS UPDATE ?
PUSHJ PP,LRDEQX## ;[605] YES
JRST RET.2 ;[605] GIVE INVALID KEY RETURN
;[605] HERE IF RECORD = RECORD KEY FOUND. IF STRT = OR STRT NOT.LS
;[605] THEN WE ARE DONE. THE CURRENT REC IS THE DESIRED ONE. IF STRT
;[605] GTR THEN GO SET PTRS TO NEXT REC.
ISTRT0: TXNE AC16,STA%GT ;[605] SKIP IF NOT START AT .GT. CURRENT RECORD
;[605] HERE IF NEED NEXT REC, WHETHER OR NOT = REC FOUND
ISTRT1: PUSHJ PP,NXTISM ;[605] GET NEXT REC IN FILE
;[605] UPDOWN WILL GIVE INVALID KEY RETURN
;[605] IF NO NEXT RECORD IS FOUND
; Now reset DAKBP and IAKBP pointers, in case del/rewrt follows
; first must save the record area in AUXBUF
MOVE AC1,AUXBUF ; Auxbuf destination
HRL AC1,FLG ; Get record area addr. source
HRRZ AC2,AC1 ;
ADD AC2,RCARSZ(I12) ; Get record area size, calc last word
BLT AC1,-1(AC2) ; Copy record area to AUXBUF
; Now reset record area to record pointed to by START
PUSHJ PP,MOVBR ; Copy buffer to record area
; Not restore record area
HRLZ AC1,AUXBUF ; AUXBUF source
HRR AC1,FLG ; Get record area addr. destination
HRRZ AC2,AC1 ;
ADD AC2,RCARSZ(I12) ; Get record area size, calc last word
BLT AC1,-1(AC2) ; Copy AUXBUF to record area
;
SETOM NNTRY(I12) ;[605] NOTE THAT CNTRY POINTS TO NEXT RECORD
HRRZ AC0,D.RFLG(I16) ; GET SOME FLAGS
TRZE AC0,SAVNXT ; CLEAR FLAG FOR NXT REC POS SAVED
HRRM AC0,D.RFLG(I16) ; PUT IT BACK
PUSHJ PP,CLRSTS ;[605] SET NO ERROR FILE STATUS
SKIPE F.WSMU(I16) ;[605] SIMULTANEOUS UPDATE ?
PUSHJ PP,LRDEQX## ;[605] YES
POPJ PP, ;[605] AND GIVE GOOD RETURN TO USER PROGRAM
RRDIVK: SKIPE BRISK(I12) ;SKIP IF SLOW MODE
JRST RRDIV4 ;JUMP IF FAST MODE
TLOE FLG1,RIVK ;[466] SET INVALID-KEY, FIRST TIME?
JRST RRDIV4 ;[466] NO
TLNN FLG,OPNOUT ;[466] IS FILE OPEN FOR OUTPUT
JRST IBSTO1 ;[466] NO, REPEAT
;MAKE CNTRY POINT AT THE RECORD PRECEEDING THE 'NOT-FOUND' RECORD
RRDIV4: HRRZI AC0,-1(AC4) ;ADR OF THE RECORD HEADER WORD
HRRZ AC2,DRTAB ;
RRDIV3: SKIPL AC3,(AC2) ;ADR OF FIRST REC-HEADER WORD IN THIS BLOCK
CAIN AC0,(AC3) ;CURRENT RECORD?
SKIPA AC3,-1(AC2) ;YES, GET ADR OF PREVIOUS REC-HDR
AOJA AC2,RRDIV3 ;NO, TRY AGAIN
ADDI AC3,1 ;FIRST WORD AFTER HEADER
CAME AC2,DRTAB ;FIRST RECORD OF THE FILE?
JRST RRDIV2 ;NO
SETOM NNTRY(I12) ;NOTE CNTRY POINTS TO NEXT ENTRY
MOVE AC0,IOWRD(I12) ;
ADDI AC0,2 ;
HRRM AC0,CNTRY(I12) ;POINT AT FIRST RECORD IN BLOCK
JRST RRDIV1
RRDIV2: HRRZM AC3,CNTRY(I12) ;POINT AT FIRST REC BEFORE 'NOT -FOUND' REC
SETZM NNTRY(I12) ;[275] CLEAR NNTRY SO CNTRY POINTS TO CURRENT ENTRY
RRDIV1: TXNE AC16,V%STRT ;[605] IS THIS START??
JRST RDIV1B ; YES
TLNE FLG1,SEQ ; [610] SKIP IF NOT SEQ READ
POP PP,(PP) ; [610] ELSE THROW AWAY NXTISM RETURN
POP PP,AC0 ; THROW AWAY IBS RETURN
TXNE AC16,V%READ ;Read?
JRST RDIV1A ; Yes, cont
AOS (PP) ;No, RERITE OR DELET
SETZM NNTRY(I12) ; Clear next rec flag, no current rec
SETZM CNTRY(I12) ; CLEAR CURRENT DATA ENTRY TO INDICATE
; SEQ READ CURRENT ENTRY IS NOT SET
RDIV1A: SKIPE F.WSMU(I16)
PUSHJ PP,LRDEQX## ;CALL LRDEQX IF FILE OPEN FOR SIMULTANEOUS UPDATE
PUSHJ PP,SETS23 ;[601] SET NO RECORD ERROR
TXNE AC16,V%DLT ; RERITE AND READ SKIP
POPJ PP, ; DELETE ALREADY HAS A SKIP EXIT
JRST RET.2 ;INVALID-KEY RETURN
RDIV1B: ;
SKIPE F.WSMU(I16) ;DOING SMU OPTION 1?
PUSHJ PP,LRDEQX## ; YES, GO DEQ IMPLICITLY
JRST RET.2 ;[605] GIVE SKIP RETURN TO START CALL
;SEQUENTIAL READ
SREAD: TLO FLG1,SEQ ;FLAG SREAD
TXNE AC16,V%RTAN ;[JSM] DOING SMU RETAIN?
JRST SR1 ;[JSM] YES, BYPASS THE "SAVE"
SKIPLE SU.FRF ; IS THIS RETAIN OF DEL/REWRIT?
PUSHJ PP,SVDLRW ; YES, SAVE "CURRENT" RECORD POSITION
SR1: PUSHJ PP,NXTISM ;[605] SET PTRS TO NEXT REC
SETZM NNTRY(I12) ;[605] NOTE CNTRY POINTS AT CURRENT ENTRY
PUSHJ PP,SETLRW ;[605] SET UP LRW INCASE A 'DELET' OCCURED
SKIPN SU.FRF
JRST MOVBR ;[605] JUMP IF NOT FAKE READ TO MOVE RECORD
; HERE IF FAKE READ TO GET BLOCK NUMBER
HRRZ AC2,CNTRY(I12) ;[447] GET CURRENT REC ADDR IN BUFFER
ADD AC2,DBPRK(I12) ;[447] ADD RELATIVE DATA-REC-KEY PTR
MOVEM AC2,SU.RBP ; SAVE IT FOR RETAIN
JRST IREADF ; GET THE BLOCK NUMBER AND EXIT
;[605] NXTISM SETS THE ISM PTRS TO ADDRESS THE NEXT NONE NULL RECORD
;[605] ON THE ISAM FILE. USES CODE THAT WAS INLINE AT SREAD CALL TO NXTISM
NXTISM: SKIPE CNTRY(I12) ;[605] IS THIS THE FIRST READ EVER?
JRST SREAD1 ; NO
HRRZ AC0,D.RFLG(I16) ; GET SOME FLAGS
TRZE AC0,SAVNXT ; CLEAR FLAG FOR NXT REC POS SAVED
JRST NXTIS0 ; AND GO RESTORE CURRENT POSITION IF
; DELETE OR REWRITE WAS LAST
TXO FLG1,FSTIDX ; SET 1ST READ SEQ SCAN FLAG
PUSHJ PP,IBS ; FIND FIRST DATA RECORD
TXZ FLG1,FSTIDX ; CLEAR 1ST READ SEQ SCAN FLAG
JRST SREAD2
; HERE TO RESTORE THE "CURRENT RECORD POSITION" TO BEFORE
; THE REWRITE OR DELETE THAT EXECUTED PREVIOUSLY
; RWDLKY HAS NNTRY,,ADR-DAK-AND-IAK-SAV-AREA
NXTIS0: SKIPN SU.FRF ; IF RETAIN FAKE READ
; WE WANT SAVED POS TO STAY UNTIL REAL I-O
; NEEDS IT
HRRM AC0,D.RFLG(I16) ; ELSE RESET RFLGS
HRL AC1,RWDLKY(I12) ; GET ADDR OF CNTRY ADJ KEY COPY(SOURCE)
HRR AC1,DAKBP(I12) ; GET ADDR OF ADJ DATA KEY KEY(DESTINATION)
; If SVNXRT is non-zero then RWDLRT has save area address just after
; dat keys
HLRZ AC2,AC1 ; GET HEAD OF SOURCE
SKIPE SVNXRT(I12) ; Is RETAIN save area being used?
HRRZ AC2,RWDLRT(I12) ; Yes, then use the saved "save area" address
BLT AC1,-1(AC2) ; COPY TO AREA JUST BEFORE SAVE AREA
; (SAV AREA IMMEDIATELY FOLLOWS IDX DAT KYS )
; NOW CALL IBS TO REGET THE IDX AND DATA BLKS FOR CNTRY
PUSH PP,FLG1 ; Save flags
TLZ FLG1,SEQ ; TEMP INDICATE NONE SEQ SEARCH
PUSH PP,AC16 ; Save verb flags
TXO AC16,V%STRT ; MARK TO GET START TYPE IBS FAILURE RETURN
SKIPE SU.FRF ; IS THIS FAKE SMU READ?
PUSH PP,NNTRY(I12) ; YES, save next rec flag, for INVALID KEY
PUSHJ PP,IBS ; SEARCH FOR OLD CNTRY
TRNA ; SKIP FOR IBS SUCCESS
JRST NXTIX2 ; IBS FAIL,SKIP NNTRY RESET, RRDIVK RESET IT
SKIPE SU.FRF ; IS THIS FAKE SMU READ?
POP PP,(PP) ; Yes, discard saved NNTRY value
HLRZ AC1,RWDLKY(I12) ; GET NNTRY VALUE
SKIPN SU.FRF ; DON'T RESET IF RETAIN
MOVEM AC1,NNTRY(I12) ; ELSE RESET IT
JRST NXTIX1 ; Reset flags, and cont
; Must reset saved value if the restore got invalid return. record
; is not there now, resave "current" "current" record
NXTIX2: HRRZ AC0,D.RFLG(16) ; Get flags for SDLRW1
PUSHJ PP,SDLRW1 ; Force save "current position"
SKIPE SU.FRF ; IS THIS FAKE SMU READ?
POP PP,NNTRY(I12) ; YES, reset next rec flag
NXTIX1: POP PP,AC16 ; Reset verb flags
POP PP,FLG1 ; Reset flags
;TRY FOR THE NEXT DATA REC IN THIS BLOCK
SREAD1: SETZ LVL, ;WE ARE AT LEVEL 0!
HRRZ AC4,CNTRY(I12) ;CURRENT ENTRY
TXNE AC16,V%RTAN ;[JSM] DOING SMU RETAIN?
JRST SR2 ;[JSM] YES, CNTRY PROBABLY BLOWN AWAY
SKIPE NNTRY(I12) ;CNTRY ALREADY POINTING AT NEXT ENTRY?
JRST SREAD2 ;YES
SR2: LDB AC1,RSBP(I12) ;
IDIV AC1,D.BPW(I16) ;
JUMPE AC2,.+2 ;
ADDI AC1,1 ;
ADDI AC4,1(AC1) ;NEXT ENTRY
SREAD2: SKIPE -1(AC4) ;NULL REC = LAST REC
CAMLE AC4,LRW(I12) ;WAS THAT THE LAST REC?
PUSHJ PP,UPDOWN ;YES, GET THE NEXT
HRRM AC4,CNTRY(I12) ;SAVE AS CURRENT ENTRY
; POPJ PP, ;[605][1075] RETURN
JRST SETLRW ;[1075] [605] GO UPDATE LRW
;LOOK UP AND DOWN THROUGH THE INDEX FOR THE NEXT REC
UPDOWN: ADDI LVL,1 ;UP AN INDEX LEVEL
CAMLE LVL,MXLVL(I12) ;ANY MORE LEVELS?
JRST UPDOW1 ;NO, INVALID KEY EXIT
MOVE AC4,@CNTRY0(I12) ;GET THE LAST ENTRY
SKIPN @NNTRY0(I12) ;CNTRY ALREADY AT NEXT ENTRY?
ADD AC4,IESIZ(I12) ;NO, THE CURRENT ENTRY
HRRZ AC2,@IOWRD0(I12) ;
ADD AC2,IBLEN(I12) ;
HRRZI AC2,3(AC2) ;UPPER LIMIT
SKIPE (AC4) ;IF NULL, REST OF BLOCK IS EMPTY
CAIG AC2,(AC4) ;ANY MORE ENTRIES AT THIS LEVEL?
PUSHJ PP,UPDOWN ;NO, UP ANOTHER LEVEL
HRRM AC4,@CNTRY0(I12) ;CURRENT ENTRY SAVED
SETZM @NNTRY0(I12) ;CNTRY POINTS AT CURRENT ENTRY
SOJL LVL,RET.1 ;DOWN AN INDEX LEVEL
PUSHJ PP,GETBLK ;GET NEXT BLOCK
MOVE AC4,@IOWRD0(I12)
ADDI AC4,2 ;
JUMPE LVL,RET.1 ;
AOJA AC4,RET.1 ;CURRENT ENTRY OR REC
UPDOW1: POP PP,AC0 ;[605] POPOFF THE RETURNS
POP PP,AC0 ;[605] POPOFF THE RETURNS
SOJG LVL,.-1 ;
PUSHJ PP,SETS10 ;SET STATUS
JRST RET.2 ;INVALID KEY RETURN
;HERE FROM GETBLK VERSION NUMBER DISCREPANCY WHEN SREADING
UDVERR: TLNN FLG1,VERR ;IF WE'VE BEEN HERE BEFORE OR
SKIPN CNTRY(I12) ; THIS IS THE FIRST READ EVER
JRST UDVER1 ; LEAVE THE STACK ALONE.
JUMPE LVL,UDVER1 ; SAME THING IF A DATA BLOCK
POP PP,(PP) ;MAKE THE STACK RIGHT
SOJG LVL,.-1 ;
;MOVE THE CURRENT KEY TO THE RECORD KEY
UDVER1: LDB AC1,KY.TYP ; GET KEY TYPE
CAIGE AC1,3 ; DISPLAY?
JUMPN AC1,.+3 ; JUMP IF NUMERIC DISPLAY
CAIGE AC1,7 ; SKIP IF COMP-3
JRST UDVER2 ; DISPLAY, FIXED, OR FLOATING POINT
;CONVERT BINNARY TO DISPLAY KEY
PUSHJ PP,SAVAC. ;SAVE THE ACS
MOVE AC0,2(AC4) ;THE KEY
LDB AC2,KY.MOD ; GET KEY MODE
HLRZ AC10,PDTBL(AC2) ; GET CONVERSION ROUTINE
LDB AC2,KY.TYP ; GET KEY TYPE
CAIL AC2,7 ; IF COMP-3
HRRZI AC10,PC3. ; USE THIS ROUTINE
MOVE AC15,F.WBSK(I16);BYTE POINTER TO RECORD KEY
TLZ AC15,7777 ;MAKE A PARAMETER WORD FOR PD6/7.
LDB AC1,KY.SIZ ; GET KEY SIZE
; [502] CHANGE AC15 TO AC2 FOR CALL TO PD6. OR PD7. BECAUSE PD USES 15.
TSO AC2,AC1 ;[502] INCLUDE THE KEY SIZE
HRRZI AC16,AC2 ;[502] AC0 IS SOURCE,,AC15 IS PARAMETER WRD
PUSHJ PP,(AC10) ;CALL PD6. OR PD7.
PUSHJ PP,RSTAC. ;RESTORE ACS
JRST UDVER3 ;--DONE--
;JUST MOVE THE KEY
UDVER2: HRLI AC1,2(AC4) ;MOVE CURRENT KEY TO RECORD KEY
HRR AC1,F.WBSK(I16) ;FROM,,TO
MOVE AC2,IESIZ(I12) ;
SUBI AC2,2 ;LEN
ADDI AC2,-1(AC1) ;UNTIL
BLT AC1,(AC2) ;MOVIT
UDVER3: PUSHJ PP,VNDE ;[307] IF TOP INDEX BLOCK WAS SPLIT - TRY AGAIN
TRN ;
TLOE FLG1,VERR ;
JRST LV2SK3 ;[307] NO - GIVE ERROR MESSAGE AND QUIT
MOVE LVL,MXLVL(I12) ;[307] OK - TAKE IT FROM THE TOP
PUSHJ PP,@GETSET(I12) ;
PUSHJ PP,IBSTO1 ;
;SET LOW-VALUES TO RECORD KEY
LV2SK.:: MOVE AC1,F.WBSK(I16) ;RECORD KEY BYTE-POINTER
HLRZ AC12,D.BL(I16)
LDB AC3,KY.TYP ; GET KEY TYPE
CAIL AC3,7 ; COMP-3?
JRST LV2SK1 ; YES
CAIGE AC3,3 ;DISPLAY ?
JRST LV2SK2 ;YES
;FIXED OR FLOATING POINT
MOVSI AC0,400000 ;ASSUME IT IS A COMP ITEM
CAILE AC3,4 ;FIXED POINT ?
ADDI AC0,1 ;NO, COMP-1
MOVEM AC0,(AC1) ;TO RECORD KEY
TLNN AC3,1 ;TWO WORDS ?
MOVEM AC0,1(AC1) ;
POPJ PP, ;NO, EXIT
;COMP-3
LV2SK1: LDB AC3,KY.SGN ; GET SIGN BIT
SKIPN AC3 ; SKIP IF UNSIGNED
SKIPA AC2,[9B13+15B17+9B31+9B35] ; LOW-VALUES
;DISPLAY
LV2SK2: SETZ AC2, ; LOW VALUES FOR DISPLAY
LDB AC0,KY.SIZ ; GET KEY SIZE
IDPB AC2,AC1 ;DEPOSIT SOME LV'S
SOJG AC0,.-1
TLNN AC2,-1 ; SKIP IF SIGNED COMP-3
POPJ PP, ;
MOVSS AC2 ; GET THE LSAT BYTE
DPB AC2,AC1 ; "9-"
POPJ PP,
;ERROR MESSAGE OR IGNORE THE ERROR
LV2SK3: PUSHJ PP,GBVER ;IGNORE ERROR?
JRST LV2SK. ;YES - RESTORE RECORD KEY
SUBTTL DELETE and REWRITE VERBs
;A DELETE VERB LOOKS LIKE:
;FLAGS,,ADR WHERE ADR = FILE TABLE ADDRESS
;CALL+1: NORMAL RETURN
;CALL+2: "AT-END" OR "INVALID-KEY" RETURN
DELET.: SKIPE F.WSMU(I16) ;ANY RETAINED RECORDS?
PUSHJ PP,SU.DL ; YES
TXO AC16,V%DLT ;
JRST RERIT1 ;
;HERE TO REWRITE AN EXISTING RECORD
;A REWRITE VERB LOOKS LIKE:
;FLAGS,,ADR WHERE ADR = FILE TABLE ADDRESS
;XWD
;CALL+1: NORMAL RETURN
;CALL+2: "AT-END" OR "INVALID-KEY" RETURN
RERIT.: SKIPE F.WSMU(I16) ;ANY RETAINED RECORDS?
PUSHJ PP,SU.RW ; YES
TXO AC16,V%RWRT
RERIT1: MOVE AC0,[FS.ZRO,,FS.FS];ZERO THE ERROR
BLT AC0,FS.IF ; STATUS WORDS.
HRRZ AC15,(PP) ;(UOCAL.)
MOVE AC15,(AC15) ;
PUSHJ PP,WRTSUP ;
TLNN FLG,OPNOUT ;FILE OPEN FOR OUTPUT?
JRST ERROPN ;NO
TXNE AC16,V%DLT ;IS IT DELET?
JRST RERIT3 ; YES,SKIP I-O CHECK
LDB AC3,WOPRS. ;NO,GET ACTUAL REC SIZE
TLC FLG,OPNIO ;[622]
TLCN FLG,OPNIO ;[622] OPEN I-O?
JRST RERIT3 ; YES,NEXT CHECK
MOVE AC2,[BYTE(5)10,31,20,6,14]; NO,ERROR
PUSHJ 17,MSOUT. ; OUTPUT MESS,I-O REQUIRED FOR
OUTSTR [ASCIZ/ for I-O/] ;THIS VERB
JRST KILL.
RERIT3: LDB AC0,F.BFAM ;GET ACCESS MODE
JUMPE AC0,RERT30 ;IF SEQ, LAST OPERATION CHECK
TLNN FLG,IDXFIL ;ISAM?
JRST RANDOM ; NO,
JRST RERIT4 ; YES,
; LAST I-O OPERATION MUST HAVE BEEN A READ FRO SEQ ACCESS
RERT30: TLNN FLG,IDXFIL ;ISAM?
JRST RERT3A ; NO, GO ON
; CHECK ISAM READ LAST IO (RDLAST) FLAG FOR SEQ ACCESS CHECK
HRRZ AC0,D.RFLG(I16) ; GET SOME FLAGS
TRZN AC0,RDLAST ;[1121] WAS READ LAST IO OPERATION
JRST ERDLRW ; NO GIVE ERROR CASE
HRRM AC0,D.RFLG(I16) ;[1121] STORE FLAG
JRST RERIT4 ;[1121] YES, CHECKS OK
RERT3A: HLRZ I12,D.BL(I16) ; GET BUFFER POINTER
SKIPE R.WRIT(I12) ; READ LAST I-O ?
JRST ERDLRW ; NO, ERROR
MOVEI AC0,RDLAST
ANDCAM AC0,D.RFLG(I16) ;BUT MAKE SURE ITS OFF
JRST RANDOM ; YES, CHECKS OK
ERDLRW: MOVEI AC0,FS%43 ;GIVE FS FOR NO PRECEDING VALID READ.
MOVEM AC0,FS.FS ; AND SAVE IT FOR REPORTING
MOVEI AC0,FE%61 ;ERROR NUMBER
SETOM FS.IF ;IDX FILE
TLNE FLG,IDXFIL ;ISAM FILE?
ADD AC0,[E.FIDX] ;YES
SETZ AC2,
PUSHJ PP,IGCVR ;IGNORE ERROR?
JRST RERT3B ;YES, GIVE A FAILURE RETURN
RERT3C: PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ/A successful READ must precede DELETE or REWRITE for SEQUENTIAL access files/]
MOVE AC2,[BYTE (5)10,31,20,14]
PUSHJ PP,MSOUT. ;STANDARD PART OF MESSAGE
JRST KILL ;GIVE UP
RERT3B: SKIPL WANT8. ;WANT 8x FUNCT?
JRST RERT3C ;NO, GIVE ERROR ANY WAY
TXNE AC16,V%RWRT ;REWRITE?
AOS (PP) ;YES, ACCOUNT FOR EXTRA WORD FOLLOWING
JRST RET.2 ;RETURN WITH FAILURE
; HERE FOR ISAM RERIT AND DELETE
RERIT4: PUSHJ PP,LVTST ;LOW-VALUES IN RECORD KEY?
JRST LVERR ;YES, ITS ILLEGAL
PUSHJ PP,SVDLRW ; save current record position
JRST RRIT2A ; and continue
; SVDLRW routine to save "current" record when about
; to do a DELETE or REWRITE, or a RETAIN for
; either.
;
; alternate entry skip SAVNXT check, sav it no matter what
; at SDLRW1: used when recovering from NXTIS0 reset that
; gets RRDIVK return (called from NXTIX2)
;
; on entry I11 = address of buffer
; AC16 = filtab address
;
; uses AC0, AC1, AC2
; SAVE THE CURRENT POSITION ADJUSTED KEY SO THE A SEQUENTIAL OPERATION
; FOLLOWING REWRITE OR DELETE WILL GET THE POSITION BEFORE THE DELETE
; OR REWRITE (74 ONLY FOR 12B)
SVDLRW: HRRZ AC0,D.RFLG(I16) ; GET SOME FLAGS
TRNN AC0,SAVNXT ; IS DEL/RWT SAV ACTIVE?
JRST SDLRW1 ; No go save current position
SKIPG SU.FRF ; IS THIS DEL/REWRIT RETAIN?
POPJ PP, ; No, cont
TXNE AC16,V%RNXT ; Yes, and READ NEXT?
SETOM NNTRY(I12) ; Yes, then reset NNTRY as BLKNUM wants
POPJ PP, ; DON'T SAVE IT AGAIN
; IF CNTRY= 0 NO "CURRENT" REC YET, NO NEED TO SAVE IT
SDLRW1: SKIPE CNTRY(I12) ; IS THERE A "CURRENT" REC LOC?
JRST SDLRW2 ; YES, SAVE IT
SKIPG SU.FRF ; NO CURRENT REC, IS THIS DEL/REWRIT RETAIN?
POPJ PP, ; NO, CONT, DON'T SAVE "CURRENT"
; THIS WILL CAUSE NEXT READ TO GET FIRST REC
; BECAUSE CNTRY WILL REMAIN 0
; IF DEL/REWRT RETAIN MUST FIND FIRST RECORD, SO ITS KEY CAN BE SAVED
PUSHJ PP,@GETSET(I12) ; First initialize keys
TXO FLG1,FSTIDX ; SET 1ST READ SEQ SCAN FLAG
PUSHJ PP,IBS ; FIND FIRST DATA RECORD
TXZ FLG1,FSTIDX ; CLEAR 1ST READ SEQ SCAN FLAG
HRRZ AC0,D.RFLG(I16) ; Now restore RFLG
SETOM NNTRY(I12) ; SET "CURRENT IS NEXT" FLAG
SDLRW2: TRO AC0,SAVNXT ; SET REWRITE WAS DONE,NXT KEY SAVED
HRRM AC0,D.RFLG(I16) ; PUT BACK FLAGS
HRR AC1,NNTRY(I12) ; NO,GET "NXT IS CURRENT" FLG
HRLM AC1,RWDLKY(I12) ; SET LEFT OF SAV ADR AS NNTRY FLG
SKIPLE SU.FRF ; IF RETAIN CASE
SETOM NNTRY(I12) ; THEN RESET NNTRY AS BLKNUM TRIED TO DO
HRR AC1,RWDLKY(I12) ; GET ADDR OF CNTRY ADJ KEY COPY(DEST)
HRL AC1,DAKBP(I12) ; GET ADDR OF ADJ DATA KEY (SOURCE)
HRRZ AC2,IESIZ(I12) ; GET IDX KEY SIZ (EXTRA 2 WDS)
LSH AC2,1 ; TIMES 2 (EXTRA USED TO OFFSET WRAP AROUND)
ADDI AC2,(AC1) ; ADD LENGTH TO DESTINATION
BLT AC1,-1(AC2) ; COPY KEY TO SAV AREA(2 EXTRA FOR WRAP
; AROUND AND 2 FOR IDX HDR WDS GOT FROM IESIZ )
POPJ PP, ; ALL DONE
RRIT2A: AOS RWRSTA(I12)
TLZ FLG1,F1CLR ;[605] INITIALIZE FLG1 FOR ISAM FLAGS
PUSHJ PP,SETIC ;SET THE INDEX CHANNEL
PUSHJ PP,@GETSET(I12) ;ADJKEY OR GD67 OR FPORFP
PUSHJ PP,IBS ;FIND THE RECORD
PUSHJ PP,SETLRW ;FIND THE LAST RECORD WORD
PUSHJ PP,SHFREC ;MAKE SURE THE NEW REC WILL FIT
TXNE AC16,V%DLT ;DELET ?
JRST DEL01 ;YES
PUSHJ PP,MOVRB ;MOVE THE RECORD
RERIT2: PUSHJ PP,WDBK ;WRITE THE DATA BLOCK
SKIPE F.WSMU(I16) ; SIMULTANEOUS - UPDATE?
PUSHJ PP,LRDEQX## ; YES
PUSHJ PP,CLRSTS ;[601] SET STATUS TO 00
MOVEI AC1,RDLAST ; CLEAR READ LAST IO OPERATION
ANDCAM AC1,D.RFLG(I16)
SETZM NNTRY(I12) ; Clear next rec flag, no current rec
SETZM CNTRY(I12) ; CLEAR CURRENT DATA ENTRY TO INDICATE
; SEQ READ CURRENT ENTRY IS NOT SET
TXNN AC16,V%DLT ;DON'T INCREMENT PC IF DELETE
AOS (PP)
POPJ PP, ;RETURN TO USER
DEL01: HRRZ AC2,LRW(I12) ;
SETZM 1(AC2) ;TERMINATE THE DATA BLOCK
HRRZ AC3,IOWRD(I12)
CAMN AC2,AC3 ;IS DATA BLOCK EMPTY ?
PUSHJ PP,DEL10 ;YES, GO UPDATE THE INDEX
SKIPE OLDBK ;ANYTHING TO DE-ALLOCATE?
PUSHJ PP,DALC ;YES
JRST RERIT2
;IF NOT FIRST ENTRY IN THE INDEX BLOCK
; JUST DELET THE ENTRY & EXIT
DEL10: MOVE AC1,USOBJ(I12) ;ADR OF EMPTY BLOCK
MOVEM AC1,OLDBK ;SAVE FOR DE-ALLOCATION
DEL11: ADDI LVL,1 ;UP A LVL
HRRZ AC1,@CNTRY0(I12)
HRRZ AC0,@IOWRD0(I12) ;
ADDI AC0,3
CAME AC0,AC1 ;FIRST ENTRY THIS BLK ?
JRST DEL40 ;NO, DELET ENTRY & EXIT
HLL AC1,IAKBP(I12) ;[276] BYTE POINTER TO DATA RECORD KEY
PUSHJ PP,LVTSTI ;TEST FOR LOW-VALUES
JRST DEL13 ;LOW-VALUES!
HRRZ AC1,@CNTRY0(I12) ;FIRST WORD OF CURRENT ENTRY
SETZM (AC1) ;BLOCK IS EMPTY; CLEAR THE BLOCK NUMBER
ADD AC1,IESIZ(I12)
SKIPN (AC1) ;IS IB EMPTY ?
JRST DEL11 ;YES, UP A LEVEL & DELET ITS ENTRY
HRRZ AC1,@CNTRY0(I12)
PUSHJ PP,DEL40 ;NO, DELET THIS ENTRY
MOVE AC3,@CNTRY0(I12) ;SETUP AC3 FOR DEL50
AOJA LVL,DEL50 ;FIX NEXT LEVEL'S KEY
DEL13: SETZM OLDBK ;SAVE THIS EMPTY BLOCK
HRRZ AC1,@CNTRY0(I12)
SETZM 1(AC1) ;MAKE VERSION NUMBER BE SAME AS DATA'S
ADD AC1,IESIZ(I12)
SKIPN (AC1) ;IS IB EMPTY ?
JRST WIBK ;YES, EXIT
;KEY = LOW-VALUES SO JUST UPDATE BLOCK / VERSION NUMBERS
HRRZ AC1,@CNTRY0(I12)
MOVE AC2,AC1 ;FIRST ENTRY
ADD AC1,IESIZ(I12) ;SECOND ENTRY
MOVE AC0,(AC1)
MOVEM AC0,(AC2) ;BLOCK NUMBER
MOVE AC0,1(AC1)
MOVEM AC0,1(AC2) ;VERSION NUMBER
;DELET AN INDEX ENTRY
DEL40: HRR AC2,AC1
ADD AC1,IESIZ(I12)
HRL AC2,AC1 ;FROM,,TO
HLRO AC6,@IOWRD0(I12)
MOVNS AC6
ADD AC6,@IOWRD0(I12) ;LAST WORD OF LAST ENTRY
DEL41: CAIG AC1,(AC6) ;STILL IN ACTIVE DATA?
SKIPN (AC1) ;YES, NULL ENTRY?
JRST DEL42 ;DONE
ADD AC1,IESIZ(I12) ;
JRST DEL41
DEL42: SUB AC1,IESIZ(I12) ;
BLT AC2,-1(AC1) ;
SETZM (AC1) ;TERMINATE THE ENTRIES
SETOM @NNTRY0(I12) ;NOTE CNRTY POINTS AT NEXT ENTRY
JRST WIBK ;WRITE THE NEW INFO
;OK NEXT LEVEL, UPDATE THE KEY
DEL50: CAMLE LVL,MXLVL(I12) ;ANY MORE LEVELS?
POPJ PP, ;NO - EXIT
HRRZ AC5,@CNTRY0(I12) ;ENTRY'S FATHER
HRLI AC1,2(AC3) ;FROM,,0
HRRI AC1,2(AC5) ;FROM,,TO
ADD AC5,IESIZ(I12) ;UNTIL+1
BLT AC1,-1(AC5) ;MOVE THE KEY
PUSHJ PP,WIBK ; AND WRITE IT OUT
;SEE IF THIS IS FIRST ENTRY IN INDEX BLOCK
MOVE AC3,@CNTRY0(I12) ;CURRENT ENTRY
HRRZ AC0,@IOWRD0(I12) ;BEGINNING OF BLOCK
CAIE AC0,-3(AC3) ;IF NOT THE FIRST ENTRY
POPJ PP, ; EXIT
AOJA LVL,DEL50 ; ELSE UPDATE NEXT LEVEL'S KEY
;HERE FROM WRITE.
IWRITE: TLZ FLG1,F1CLR ;[605] INITIALIZE FLG1 FOR ISAM FLAGS
PUSHJ PP,LVTST ;LOW VALUES IN RECORD KEY?
JRST LVERR ;ILLEGAL!
; CLEAR SAVED NEXT RECORD POSITION FLAG
;[1021] HRRZ AC0,D.RFLG(I16) ; GET SOME FLAGS
;[1021] TRZE AC0,SAVNXT ; CLEAR FLAG FOR NXT REC POS SAVED
;[1021] HRRM AC0,D.RFLG(I16) ; PUT IT BACK IF WAS SET
PUSHJ PP,SVDLRW ;[1021] SAVE CURRENT RECORD POSITION AND CONTINUE
AOS RWRSTA(I12) ;BUMP # OF WRITE STATEMENTS
PUSHJ PP,SETIC ;SET CHAN FOR INDEX FILE
PUSHJ PP,@GETSET(I12) ;
PUSHJ PP,IBS ;FIND WHERE TO INSERT
HRRZ AC6,D.RCL(I16) ;# OF EMPTY RECS THIS BLK
JUMPG AC6,IWRI02 ;IS CURRENT BUFFER FULL?
JRST SPLTBK ;YES, MAKE SOME ROOM
IWRI01: PUSHJ PP,WABK ;WRITE THE AUXBUF
IWRI02: HRRZ AC1,DBF(I12) ;GET BLOCKING FACTOR
CAIE AC1,1 ;DON'T NEED A HOLE IF BF = 1
PUSHJ PP,SHFHOL ;MAKE A HOLE
PUSHJ PP,SRHW ;SET THE RECORD HEADER WORD
PUSHJ PP,MOVRB ;INSERT THE RECORD
PUSHJ PP,WDBK ;MARK DATA BLOCK ACTIVE
TLZN FLG1,BVN ;[503] WAS DATA BLOCK SPLIT?
JRST IWRIX ;NO
SKIPE LIVE(I12) ;ANYTHING TO BE OUTPUT?
PUSHJ PP,WWDBK ;YES - WWRITE OUT THE DATA
;MAKE AN INDEX ENTRY & UPDATE THE INDEX FILE
IWRI04: MOVE AC1,IAKBP(I12) ;
MOVE AC0,NEWBK1 ;
MOVEM AC0,-2(AC1) ;BLOCK NUMBER
MOVE AC2,IOWRD(I12) ;
HLRZ AC0,1(AC2) ;
TRZ AC0,-100 ;CLEAR FILE FORMAT INFO
MOVEM AC0,-1(AC1) ;VERSION NUMBER
MOVE AC3,AUXBUF ;
ADD AC3,DBPRK(I12) ;[276] DATA BYTE-POINTER TO RECORD KEY
ADDI AC3,1 ;
MOVE AC2,AC3 ;
HRLZI AC1,7777 ;MASK
ANDCAM AC1,AC2 ;CLEAR BYTE SIZE
AND AC1,GDPSK(I12) ;GET KEY SIZE & SIGN
IOR AC2,AC1 ;MERGE
MOVE AC0,GDX.D(I12) ;[465] USE DATA MODE. NOT CORE MODE
PUSH PP,GDX.I(I12) ;[465] SAVE INDEX VS RECORD KEY
MOVEM AC0,GDX.I(I12) ;[465] AND USE DATA VS RECORD KEY
PUSH PP,GDPSK(I12) ;[276] SAVE IT
PUSH PP,F.WBSK(I16) ;[276] SAVE IT
MOVEM AC3,F.WBSK(I16) ;[276] FIRST KEY OF AUXBUF VS RECORD KEY
MOVEM AC2,GDPSK(I12) ;[276]
TLO FLG1,NOTEST ;[276] SKIP THE CONVERSION AT ADJKEY
PUSHJ PP,@GETSET(I12) ;PLACE FIRST KEY OF AUXBUF IN IAKBP
TLZ FLG1,NOTEST ;[276] RESTORE THE FLAG
POP PP,F.WBSK(I16) ;[276] RESTORE SYMKEK POINTER
POP PP,GDPSK(I12) ;[276] RESTORE
POP PP,GDX.I(I12) ;[465] RESTORE INDEX VS RECORD KEY
PUSHJ PP,UDIF ;UPDATE THE INDEX FILE
PUSHJ PP,WIBK ;WRITE THE INDEX BLOCK
IWRIX: PUSHJ PP,@GETSET(I12) ;[1001] RESET INDEX AND DATA POINTERS
SKIPE OLDBK ;ANY BLOCKS TO DEALLOCATE
PUSHJ PP,DALC ;YES, DOIT
;[1064] SKIPE F.WSMU(I16) ; SIMULTANEOUS - UPDATE?
;[1064] PUSHJ PP,LRDEQX## ; YES
MOVEI AC1,RDLAST ; CLEAR READ LAST IO OPERATION
ANDCAM AC1,D.RFLG(I16)
PUSHJ PP,CLRSTS ;SET STATUS TO 00
LDB AC0,F.BCRC ; GET CHP=PNT REC CNT
JUMPE AC0,.+2 ; SKIP IF NONE
PUSHJ PP,CKPREC ; DECR. COUNT AND CHKPNT IF TIME
PUSHJ PP,CHKRRN ; CHECK FOR RERUN DUMP
SKIPN F.WSMU(I16) ;[1064] SIMULTANEOUS - UPDATE?
JRST IWRIXA ;[1064] NO
SKIPN SU.FRF ;[1064] DOING FAKE READ FOR SMU?
PUSHJ PP,LRDEQX## ;[1064] NO
IWRIXA:
SETZM NNTRY(I12) ;[1021] CLEAR NEXT REC FLAG, NO CURRENT REC
SETZM CNTRY(I12) ;[1021] CLEAR CURRENT DATA ENTRY TO INDICATE
;[1021] SEQ READ CURRENT ENTRY IS NOT SET
JRST RET.2
IWIVK: SKIPN BRISK(I12) ;[466] SKIP IF NOT SLOW MODE
TLO FLG1,WIVK ;[466] SET FLAG
SUB AC4,DBPRK(I12) ;[276] POINT AT BEGINNING OF THIS ENTRY
HRRZM AC4,CNTRY(I12) ;SAVE IN CASE SEQ READ IS NEXT
IWIVK1: POP PP,(PP) ;
MOVEI AC0,FS%22 ;RECORD ALREADY EXISTS
MOVEM AC0,FS.FS ;LOAD FILE-STATUS
SKIPE F.WSMU(I16)
PUSHJ PP,LRDEQX## ;CALL LRDEQX IF FILE OPEN FOR SIMULTANEOUS UPDATE
PUSHJ PP,SETS22 ;SET STATUS TO 22
JRST RET.3
;UPDATE THE INDEX FILE
UDIF: ADDI LVL,1 ;UP A LEVEL
CAMLE LVL,MXLVL(I12) ;ANY MORE LEVELS?
JRST UDIF10 ;NO, MAKE A NEW LEVEL
;UPDATE CURRENT ENTRY BLOCK & VERSION NUMBERS
HRRO AC2,@CNTRY0(I12)
MOVE AC3,NEWBK2 ;
MOVEM AC3,(AC2) ;NEW BLOCK NUMBER
MOVE AC1,1(AC2) ;THE VERSION NUMBER
ADDI AC1,1 ;BUMP IT
CAIN LVL,1 ;A DATA BLOCK VERSION NUMBER?
TRZ AC1,-100 ;CLEAR THE FILE FORMAT INFO
MOVEM AC1,1(AC2) ;PUT IT BACK
;MUST INDEX BLOCK BE SPLIT?
MOVE AC1,IBLEN(I12) ;
ADD AC1,@IOWRD0(I12)
ADDI AC1,3 ;SKIP OVER THE HEADER
SUB AC1,IESIZ(I12) ;POINT AT LAST ENTRY
SKIPE (AC1) ;MUST IDXBLK BE SPLIT?
JRST UDIF20 ;YES
;MAKE A HOLE FOR NEW ENTRY
UDIF30: MOVE AC1,IESIZ(I12) ;DISPLACEMENT
HRRO AC2,@CNTRY0(I12)
ADD AC2,AC1 ;
SKIPN (AC2) ;
JRST UDIF31 ;NO HOLE NEEDED, JUST APPEND
UDIF33: ADD AC2,AC1 ;
SKIPE (AC2) ;IS THIS LAST ENTRY?
JRST UDIF33 ;NO
HRRZ AC0,AC2 ;
SUBI AC2,1 ;-1 ,, LEN
SUB AC0,@CNTRY0(I12) ;LEN
PUSHJ PP,SHFR00 ;MAKE HOLE
UDIF31: TLNE FLG1,WSTB ;MUST STATISTICS BLOCK BE WRITTEN?
UDIF34: PUSHJ PP,WSTBK ;YES
MOVE AC0,IAKBP(I12) ;
ADDI AC0,-2 ;
HRL AC0,AC0 ;FROM,,FROM
HRR AC0,@CNTRY0(I12) ;FROM,,TO
MOVE AC1,IESIZ(I12) ;
ADD AC0,AC1 ;
ADD AC1,AC0 ;UNTIL
TLZE FLG1,BVN ;[552] [503] IS DATA IN SECOND NEW BLOCK?
HRRM AC0,@CNTRY0(I12) ;[503] YES - UPDATE CNTRY FOR SREAD
BLT AC0,-1(AC1) ;INSERT THE ENTRY
POPJ PP, ;EXIT TO IWRITE
;BUMP THE VERSION NUMBER
UDIF20: MOVE AC2,AUXBUF
HRRZ AC3,@IOWRD0(I12)
ADDI AC3,2
MOVE AC0,-1(AC3) ;
MOVEM AC0,(AC2) ;HEADER WORD - BLOCK SIZE EXPRESSED AS 6BIT BYTES
AOS AC3,(AC3) ;IN THE CURRENT IDXBLK
MOVEM AC3,1(AC2) ; AND IN AUXBUF
;DECIDE WHERE TO SPLIT THE INDEX BLOCK
MOVE AC3,EPIB(I12) ;NUMBER OF INDEX ENTRIES
LSH AC3,-1 ;HALVE IT
IMUL AC3,IESIZ(I12) ;
ADDI AC3,3 ;
ADD AC3,@IOWRD0(I12) ;FIRST ENTRY OF 2ND HALF
TLZ AC3,-1 ;CLEAR LEFT HALF THEN COMPARE
CAMG AC3,@CNTRY0(I12) ;NEW ENTRY IN FIRST HALF?
JRST UDIF21 ;YES
;NEW ENTRY IS IN FIRST HALF OF CURRENT IDXBLK
;MOVE SECOND HALF TO AUXBUF
HLRZ AC2,@IOWRD0(I12)
MOVNI AC2,(AC2) ;
ADD AC2,@IOWRD0(I12)
HRRZM AC2,TEMP. ;UNTIL - FOR ZEROING IDXBLK
SUBI AC2,-1(AC3) ;<LEN-1> OF 2ND HALF
ADDI AC2,2 ;SKIP OVER HEADER
ADD AC2,AUXBUF ;UNTIL
HRL AC1,AC3 ;FROM
HRR AC1,AUXBUF ;TO
ADDI AC1,2 ;SKIP OVER HEADER
BLT AC1,-1(AC2) ;
;INSERT NEW ENTRY IN CURRENT IDXBLK
SETZM (AC3) ;SET LOOP CATCHER FOR UDIF33
ADD AC3,IESIZ(I12) ;INCLUDE THE NEW ENTRY
MOVEM AC2,TEMP.1
MOVEM AC3,TEMP.2
PUSHJ PP,UDIF30
MOVE AC2,TEMP.1
MOVE AC3,TEMP.2
JRST UDIF25 ;FINISH UP
UDIF21: TLO FLG1,IIAB ;INSERTION IS IN AUXBUF
ADD AC3,IESIZ(I12) ;PUT ONE MORE ENTRY IN 1ST HALF
CAMLE AC3,@CNTRY0(I12) ;NEW ENTRY FIRST IN AUXBUF?
JRST UDIF22 ;YES
;MOVE FIRST PART OF 2ND HALF TO AUXBUF
HRL AC2,AC3 ;FROM
HRR AC2,AUXBUF ;TO
ADDI AC2,2 ;SKIP OVER HEADER & VERSION NUMBER
HRRZ AC1,@CNTRY0(I12)
SUBI AC1,(AC3) ;LEN
ADD AC1,IESIZ(I12) ;INCLUDE THE CURRENT ENTRY
HRRZM AC1,TEMP. ;LEN OF 1ST PART
ADDI AC1,(AC2) ;UNTIL
BLT AC2,-1(AC1) ;MOVE FIRST PART
JRST UDIF23
;NEW ENTRY IS FIRST IN AUXBUF
UDIF22: SETZM TEMP. ;LEN OF FIRST PART IS ZERO
HRRZ AC1,AUXBUF ;TO
ADDI AC1,2 ;SKIP OVER THE HEADER WORD
;INSERT THE NEW ENTRY
UDIF23: HRRZM AC1,TEMP.2 ;AUXBUF CNTRY, SAVE FOR MAUXI
HRR AC0,IAKBP(I12) ;
ADDI AC0,-2 ;
HRL AC0,AC0 ;
HRR AC0,AC1 ;FROM,,TO
ADD AC1,IESIZ(I12) ;UNTIL
BLT AC0,-1(AC1) ;INSERT
;MOVE REST OF 2ND HALF TO AUXBUF
HRR AC0,TEMP. ;LEN OF FIRST PART
ADD AC0,AC3 ;FROM
HRL AC0,AC0 ;FROM,,FROM
HRR AC0,AC1 ;TO
MOVE AC2,@IOWRD0(I12)
MOVE AC5,IESIZ(I12) ;
IMUL AC5,EPIB(I12) ;
ADDI AC2,2(AC5) ;LAST WORD OF LAST ENTRY
HRRZM AC2,TEMP.1 ;'LEW', SAVE FOR MAUXI
SUB AC2,TEMP. ;
ADDM AC2,TEMP. ;UNTIL, FOR CLEARING CURRENT IDXBLK
SUBI AC2,(AC3) ;LEN-1
ADDI AC2,1(AC1) ;UNTIL
BLT AC0,-1(AC2) ;REST TO AUXBUF
HRRZM AC2,LRWA ;
SOS LRWA ;LAST ACTIVE WORD IN AUXBUF, SAVE FOR MAUXI
;ZERO 2ND HALF OF CURRENT IDXBLK
UDIF25: SETZM (AC3) ;
HRL AC0,AC3 ;
HRRI AC0,1(AC3) ;FROM,,TO
HRRZ AC1,TEMP. ;
BLT AC0,(AC1) ;
;ZERO 2ND HALF OF AUXBUF
SETZM (AC2) ;
HRL AC2,AC2 ;
HRRI AC2,1(AC2) ;FROM,,TO
MOVE AC1,AUXIOW ;
HLRZ AC0,AC1 ;
SUB AC1,AC0 ;UNTIL - END OF AUXBUF
BLT AC2,(AC1) ;
;MAKE A NEW ENTRY
PUSHJ PP,ALC2IB ;GRAB TWO BLOCKS
MOVE AC0,NEWBK1 ;
MOVEM AC0,AUXBNO ;
MOVE AC1,IAKBP(I12) ;
MOVEM AC0,-2(AC1) ;BLOCK NUMBER
MOVE AC2,@IOWRD0(I12)
MOVE AC0,2(AC2) ;
MOVEM AC0,-1(AC1) ;VERSION NUMBER
MOVE AC3,AUXBUF ;MOVE KEY TO HOLDING AREA
HRLI AC3,4(AC3) ;
HRRI AC3,(AC1) ;FROM,,TO
MOVE AC2,IESIZ(I12) ;
ADDI AC2,-2(AC3) ;
BLT AC3,-1(AC2) ;
;WRITE OUT THE SPLIT BLOCKS
MOVE AC1,NEWBK2 ;
MOVEM AC1,@USOBJ0(I12) ;NEW BLOCK NUMBER FOR CURRENT IDXBLK
PUSHJ PP,WIBK ;CURRENT
PUSHJ PP,WABK ;AUXBLK
CAMN LVL,MXLVL(I12) ;IS THIS THE TOP INDEX LEVEL?
PUSHJ PP,SAVTIE ;YES, SO SAVE TOP INDEX ENTRY FOR NEW TOP-LVL
TLZE FLG1,IIAB ;WAS INSERTION IN AUXBUF?
PUSHJ PP,MAUXI ;MOVE AUXBUF TO IDXBUF
JRST UDIF ;UPDATE THE NEXT LEVEL
;CREATE ANOTHER LEVEL OF INDEX
UDIF10: CAILE LVL,12 ;MORE LEVELS AVAILABLE?
JRST UDIER ;NO
AOS MXLVL(I12) ;INCREASE MXLVL BY ONE
MOVEI AC11,@IOWRD0(I12)
SKIPN KEYCV. ;SORT IN PROGRESS?
PUSHJ PP,UDIF11 ;NO, TRY FOR MORE CORE
MOVE AC3,-1(AC11) ;YES, IOWRD OF OLD TOP INDEX BLOCK
MOVE AC5,1(AC3) ;FIRST HEADER WORD OF OLD TOP LEVEL
ADD AC5,[XWD 1,0] ;BUMP THE LEVEL BY ONE
MOVE AC1,(AC11) ;IOWRD OF NEW TOP INDEX BLOCK
MOVEM AC5,1(AC1) ;SAVE AS FIRST HEADER WORD
SETZM 2(AC1) ;VERSION NUMBER OF TOP LEVEL IS ZERO
;MAKE AN ENTRY POINTING AT OLD TOP-LEVEL
HRL AC5,IESAVE ;
HRRI AC5,3(AC1) ;TO
HRRZM AC5,@CNTRY0(I12) ;FIRST ENTRY = CURRENT ENTRY
HRRZ AC2,AC5
ADD AC2,IESIZ(I12) ;UNTIL
BLT AC5,-1(AC2) ;DOIT
PUSHJ PP,ALC1IB ;GET THE NEXT FREE BLOCK
MOVE AC1,NEWBK2 ;
MOVEM AC1,TOPIBN(I12) ;TOP INDEX BLOCK NUMBER
MOVEM AC1,@USOBJ0(I12) ; ALSO CURRENT
REPEAT 0,<
;DELETE FOR NOW AS IT CAUSES NAVY TESTS IX104 & IX204 TO FAIL
SETOM FS.IF ;[462] TURN ON THIS IS ISAM FLAG
MOVX AC0,E.FIDX+E.BIDX+FE%27 ;[462] THE ERROR MESSAGE
PUSHJ PP,IGCVR ;[462] DO USE PRO IF ANY
JRST UDIF34 ;[462] IGNORE, NO MESSAGE
>
PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /% /]
MOVE AC2,[BYTE (5)10,31,20,14]
PUSHJ PP,MSOUT1
OUTSTR [ASCIZ / should be reorganized,
The top index block was just split.
/]
JRST UDIF34
UDIER: SETOM FS.IF ;IDX FILE
MOVX AC0,E.FIDX+E.BIDX+FE%2 ;THE ERROR NUMBER
PUSHJ PP,IGCVR1 ;FATAL MESSAGE OR IGNORE ERROR?
JRST RET.2 ;NO MESSAGE JUST RETURN TO CBL-PRGM
PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /No more index levels available to /]
MOVE AC2,[BYTE (5)10,31,20]
PUSHJ PP,MSOUT1 ;KILL
UDIF11: CAIN LVL,12 ;IF HIGHEST POSSIBLE LEVEL
SKIPL @IOWRD0(I12) ; AND SPACE IS STILL AVAILABLE
JRST .+2
JRST UDIF12 ; USE THE ALLOCATED AREA
;ZERO FREE CORE
HRRZ AC1,.JBFF ;SET UP TO ZERO THE FIRST FREE WORD
CAMG AC1,.JBREL ;[320] DON'T ZERO IT IF OUT-OF-BOUNDS
SETZM (AC1) ;ZERO INITIAL WORD
HRL AC0,AC1 ;MAKE A BLT
HRRI AC0,1(AC1) ; POINTER
CAML AC1,.JBREL ;[320] EXIT
JRST UDIF13 ;[320] HERE IF DONE
HRRZ AC1,.JBREL ;MAKE A BLT TERMINATOR
SKIPE HLOVL. ;[474] ARE THERE OVERLAYS?
HRRZ AC1,HLOVL. ;[474] YES, ONLY CLEAR TO BOTTOM OF OVERLAY
BLT AC0,(AC1) ;PROPAGATE THE ZERO
UDIF13: HLRO AC1,-1(AC11) ;[320]
MOVN AC0,AC1 ;LENGTH FOR GETSPC
HRL AC1,.JBFF ;DWOI
PUSHJ PP,GETSPC ;GET SOME SPACE
JRST UDIF12 ;NO MORE CORE
HRRZ AC0,HLOVL. ;[346] GET START OF OVERLAY AREA
CAMGE AC0,.JBFF ;[346] BUFFER EXTEND INTO OVL AREA?
JUMPN AC0,UDIF15 ;ERROR IF IN OVERLAY AREA
MOVE AC0,(AC11) ;IOWD FOR ALLOCATED AREA
CAIGE LVL,12 ;SKIP IF IF CAN'T BE
MOVEM AC0,1(AC11) ;SAVE FOR NEXT TOP BLK SPLIT
MOVSS AC1 ;-LEN,,LOC
SUBI AC1,1 ;MAKE IT AN IOWD
MOVEM AC1,(AC11) ;SAVE AS CURRENT IOWRD
UDIF12: SKIPE (AC11) ;ANY CORE ALLOCATED?
POPJ PP, ;YES, PHEW!
MOVEI AC0,FS%30 ;RERMANENT ERROR
MOVEM AC0,FS.FS ;LOAD FILE-STATUS
SETOM FS.IF ;IDX FILE
MOVX AC0,E.FIDX+E.BIDX+FE%3 ;ERROR NUMBER
PUSHJ PP,IGCVR2 ;FATAL MESSAGE OR IGNORE ERROR?
JRST RET.2 ;IGNORE SO RETURN TO MAIN LINE CODE
UDIF14: PUSHJ PP,DSPL1. ;DUMP CURRENT BUFFER, APPEND CR-LF
OUTSTR [ASCIZ /Insuficient memory while attempting to split the top index block of
/]
MOVE AC2,[BYTE(5)10,31,20]
PUSHJ PP,MSOUT1 ;KILL
UDIF15: HLRZM AC1,.JBFF ;GET OUT OF OVERLAY AREA
MOVEI AC0,FS%30 ;PERMANENT ERROR
MOVEM AC0,FS.FS ;LOAD FILE-STATUS
SETOM FS.IF ;IDX FILE
MOVX AC0,E.FIDX+E.BIDX+FE%36 ;ERROR NUMBER
PUSHJ PP,IGCVR2 ;IGNORE?
JRST RET.2 ;YEP
XCT WOVLRX ;GIVE ERROR MESSAGE
JRST UDIF14 ; AND KILL
;ALOCATE TWO INDEX BLOCKS
ALC2IB: MOVE AC1,FMTSCT(I12) ;
MOVEM AC1,NEWBK1 ;
MOVE AC0,ISPB(I12) ;NUMBER OF SECTORS PER INDEX BLOCK
ADDM AC0,FMTSCT(I12) ;UPDATE FIRST EMPTY SECTOR AVAILABLE
ALC1IB: MOVE AC1,FMTSCT(I12) ;
MOVEM AC1,NEWBK2 ;
MOVE AC0,ISPB(I12) ;
ADDM AC0,FMTSCT(I12) ;
TLO FLG1,WSTB ;REMEMBER TO WRITE THE STATISTICS BLOCK
POPJ PP,
;DECIDE WHERE TO SPLIT THE BLOCK
SPLTBK: TLO FLG1,BVN ;NOTE THE BLOCK WAS SPLIT
PUSHJ PP,SETLRW ;BUMP THE VERSION NUMBERS
HRRZ AC4,CNTRY(I12) ;
SUBI AC4,1 ;ONE FOR HEADER WORD
HRRZ AC5,DBF(I12) ;DATA BLOCKING FACTOR
LSH AC5,-1 ;2ND HALF GE 1ST HALF
MOVE AC11,DRTAB ;
ADD AC11,AC5 ;BEG OF 2ND HALF
MOVE AC10,(AC11) ;
CAIG AC4,(AC10) ;NEWREC IN 2ND HALF?
JRST SPLT01 ;NO
;MAKE HEADER WORD FOR NEWREC
TLO FLG1,IIAB ;NOTE INSERTION IS IN AUX BUFFER
ADDI AC11,1 ;MAKE 1ST HALF GE 2ND HALF
LDB AC2,WOPRS. ;NEWREC SIZE
MOVEM AC2,AC6 ;FIRST PART OF HEADER WORD
JUMPGE FLG,SPLT03 ;ASCII?
ADDI AC2,2 ;<CRLF>
ADDI AC6,2 ;<CRLF>
LSH AC6,1 ;MAKE ROOM FOR BIT35
TRO AC6,1 ;MAKE IT LOOK LIKE A SEQUENCE NUMBER
SPLT03: MOVE AC3,IOWRD(I12) ;GET VERSION NUMBER
HLL AC6,1(AC3) ;HEADER WORD = VERSION # ,, RECSIZ
;HOW MANY WORDS IN NEWREC?
IDIV AC2,D.BPW(I16) ;
JUMPE AC3,.+2 ;
ADDI AC2,1 ;
ADDI AC2,1 ;PLUS ONE FOR HEADER WORD
;MOVE 1ST PART OF 2ND HALF TO AUXBUF
HRL AC0,(AC11) ;
HRR AC0,AUXBUF ;FROM ,, TO
HRRZI AC1,-1(AC4) ;
HRRZ AC3,(AC11) ;ADR OF FIRST REC-HDR TO GO IN AUXBUF
SUB AC1,AC3 ;LENGTH OF FIRST PART
HRRZM AC1,TEMP. ;LEN OF PART BEFORE NEW-REC
CAIGE AC1,0 ;IS NEW-REC FIRST IN AUXBUF?
SETZM TEMP. ;YES
ADD AC1,AUXBUF ;UNTIL
SKIPE TEMP. ;[271] DON'T DO BLT IF FIRST RECORD
BLT AC0,(AC1) ;FIRST PART
MOVEM AC6,1(AC1) ;NEWREC HEADER WORD
;MAKE ROOM FOR NEWREC & MOVE THE REST TO AUXBUF
HRL AC0,(AC11) ;
HRR AC0,AUXBUF ;
SKIPE AC6,TEMP. ;LEN OF FIRST PART
ADDI AC6,1 ;
HRL AC6,AC6 ;
ADD AC0,AC6 ;SKIP OVER FIRST PART
HLL AC3,CNTRY(I12) ;BYTE-POINTER POSITION & SIZE
HLLM AC3,TEMP.2 ;SAVE FOR MOVRBA
HRRM AC0,TEMP.2 ;WHERE TO MAKE INSERTION IN AUXBUF
AOS TEMP.2 ;
ADD AC0,AC2 ;MAKE ROOM FOR NEWREC
HRRZ AC2,LRW(I12) ;
HLRZ AC1,AC0 ;
SUBM AC2,AC1 ;
ADD AC1,AC0 ;UNTIL
BLT AC0,(AC1) ;MOVIT
JRST SPLT02
;MOVE 2ND HALF OF CURRENT BLOCK TO AUXBUF
SPLT01: HRL AC0,(AC11) ;
HRR AC0,AUXBUF ;FROM,,TO
HRRZ AC1,LRW(I12) ;
SUB AC1,(AC11) ;LEN
ADD AC1,AC0 ;UNTIL
BLT AC0,(AC1) ;
SPLT02: HRRZM AC1,LRWA ;LAST-REC-WRD FOR AUXBUF
;ZERO THE REST OF AUXBUF
HLRZ AC2,IOWRD(I12) ;
MOVE AC0,AUXBUF ;
SUBI AC0,1(AC2) ;
HRLI AC1,1(AC1) ;
HRRI AC1,2(AC1) ;FROM ,,TO
HRRZ AC2,AC0 ;UNTIL
CAIGE AC2,(AC1) ;IF UNTIL LESS THAN TO
JRST SPLT04 ; SKIP THE BLT
SETZM -1(AC1) ;ZERO THE FIRST WORD
EXCH AC0,AC1 ;
BLT AC0,(AC1) ;
;ZERO 2ND HALF OF CURRENT BLOCK
SPLT04: HRRZ AC2,(AC11) ;FIRST FREE DATA WRD LOC
SUBI AC2,1 ;LRW
HRRZI AC0,2(AC2) ;
CAMLE AC0,LRW(I12) ;CHECK BLT POINTERS
JRST SPLT05 ;FROM GE UNTIL
HRLI AC0,1(AC2) ;
SETZM 1(AC2) ;
EXCH AC2,LRW(I12) ;
BLT AC0,(AC2) ;
SPLT05: MOVE AC1,@AUXBUF ;GET THE VERSION NUMBER
HLLM AC1,(AC10) ; SO BLOCKING FACTOR OF 1 WILL WORK
PUSHJ PP,ALC2BK ;GET TWO BLKNO
MOVE AC1,NEWBK2 ;
EXCH AC1,USOBJ(I12) ;GIVE NEW BLKNO TO CURRENT BUFFER
MOVEM AC1,OLDBK ;MARK OLD ONE FOR DE-ALLOCATION
MOVE AC0,NEWBK1 ;
MOVEM AC0,AUXBNO ;GIVE 2ND NEW BLKNO TO AUXBUF
TLZN FLG1,IIAB ;INSERTION IN AUX BLOCK?
JRST IWRI01 ;NO
PUSHJ PP,WWDBK ;WRITE A DATA BLOCK
PUSHJ PP,MOVRBA ;INSERT
PUSHJ PP,WABK ;WRITE AUXBUF
PUSHJ PP,MAUXD ;MOVE AUXBUF TO DATABUF
HRRZM AC1,LRW(I12) ;
JRST IWRI04 ;
;ROUTINE MOVES CONTENTS OF AUXBUF TO DATA OR INDEX BUFFER
;UPDATES CNTRY AND USOBJ SO SEQ-READS WILL WORK
MAUXD: MOVE AC0,LRW(I12) ;
HRRZM AC0,TEMP.1 ;LAST RECORD WORD
MAUXI: MOVE AC0,TEMP.2 ;
SUB AC0,AUXIOW ;
ADD AC0,@IOWRD0(I12) ;
HRRM AC0,@CNTRY0(I12) ;CURRENTRY
MOVE AC0,AUXBNO ;
MOVEM AC0,@USOBJ0(I12) ;USETO OBJECT
MOVE AC1,LRWA ;
SUB AC1,AUXIOW ;LENGTH
ADD AC1,@IOWRD0(I12) ;UNTIL
MOVE AC0,@IOWRD0(I12)
ADDI AC0,1 ;
HRL AC0,AUXBUF ;FROM,,TO
HRRZ AC3,TEMP.1 ;
CAIL AC3,(AC1) ;ANY REMNANTS LEFT?
HRRZM AC3,AC1 ;YES, COVER THEM UP WITH ZEROES
BLT AC0,(AC1) ;DOIT!
POPJ PP,
;SAVE TOP INDEX ENTRY FOR THE NEW TOP INDEX BLOCK
SAVTIE: MOVE AC2,@IOWRD0(I12) ;
ADDI AC2,1 ;
HRLI AC2,4(AC2) ;
HRR AC2,IESAVE ;FROM,,TO
MOVE AC3,NEWBK2 ;
MOVEM AC3,(AC2) ;BLOCK NUMBER FOR THIS LEVEL
MOVE AC3,@IOWRD0(I12)
MOVE AC3,2(AC3) ;
MOVEM AC3,1(AC2) ;VERSION OF CURRENT IDX BLOCK
HRR AC3,IESIZ(I12) ;
ADD AC3,-1(AC2) ;UNTIL
ADDI AC2,2 ;WHERE THE KEY WILL GO
BLT AC2,(AC3) ;MOVIT
POPJ PP,
;MAKE TWO COPIES OF RECORD KEY
;ADJUST ONE TO MATCH IDXKEY, AND ONE TO RECKEY
ADJKEY: MOVE AC0,F.WBSK(I16) ;RECORD KEY BP
MOVE AC1,DAKBP(I12) ;DATA ADJUSTED KEY POINTER
HRRM AC1,DKWCNT(I12) ;DATA KEY WRD CNT
MOVE AC2,IAKBP(I12) ;INDEX ADJUSTED KEY POINTER
HRRM AC2,IKWCNT(I12) ;-CNT,,FRST-WRD
MOVE AC10,D.WCNV(I16); GET CONVERSION INST.
TLNE FLG1,NOTEST ; IF NOTEST - NO CONVERSION
MOVSI AC10,(TRN) ;
LDB AC4,KY.SIZ ; GET KEY SIZE
TXNN AC16,STA%AP ;BL; APPROXIMATE KEY?
JRST ADJKE1 ;BL; NO
MOVE AC5,AC4 ;BL; YES, SAVE FULL COUNT
MOVE AC4,F.AKS(I16) ; LOAD APPROXIMATE KEY SIZE
ADJKE1: ILDB C,AC0 ;RECORD KEY
XCT AC10 ; CONVERT IF NECESSARY
IDPB C,AC1 ;RECKEY
IDPB C,AC2 ;IDXKEY
SOJG AC4,ADJKE1 ;
TXNN AC16,STA%AP ;BL;APPROXIMATE KEY?
POPJ PP, ;BL; NO, RETURN
MOVN AC4,F.AKS(I16) ; YES, GET NEG APP-KEY SIZE
ADD AC4,AC5 ;BL; BYTES LEFT
TXNN AC16,STA%GT ; GREATER THAN?
TDZA C,C ; NO, LOW-VALUES
SETO C, ; YES, HIGH VALUES
ADAPKY: IDPB C,AC1 ;BL; RECKEY
IDPB C,AC2 ;BL; IDXKEY
SOJG AC4,ADAPKY ;BL; LOOP THRU REST OF RECORD KEY
POPJ PP,
;CONVERT NUMERIC DISPLAY OR COMP-3 TO ONE/TWO WRD INTEGER
GD67: PUSH 17,16 ;[1161]SAVE AC 16
MOVEI AC16,ACSAV0 ;[1161]
BLT AC16,ACSAV0+16 ;[1161]
MOVE AC16,[Z AC2,GDPSK] ;PARAMETER
ADD AC16,I12 ;INDEX IT
PUSHJ PP,@GDX.I(I12) ;CALL GD6. OR GD7. OR GD9. OR GC3.
MOVEM AC2,@IAKBP(I12)
MOVEM AC2,@DAKBP(I12)
MOVEM AC3,@IAKBP1(I12)
MOVEM AC3,@DAKBP1(I12)
HRLZI AC16,ACSAV0 ;[1161]
BLT AC16,AC16 ;[1161]
POP 17,16 ;[1161]Restore ac16
POPJ PP,
;GET SET FOR ONE/TWO WRD INTEGER
FPORFP: MOVE AC1,F.WBSK(I16) ;RECORD KEY
MOVE AC0,(AC1) ;
MOVEM AC0,@IAKBP(I12)
MOVEM AC0,@DAKBP(I12)
MOVE AC0,1(AC1)
MOVEM AC0,@IAKBP1(I12)
MOVEM AC0,@DAKBP1(I12)
POPJ PP,
;DO THE BINARY SEARCH AGAIN, THERE WAS A VERSION NUMBER DISCREPANCY
;ROUTINE CAUSES GETBLK TO REREAD INDEX/DATA BLOCKS FROM DSK
IBSTOP: POP PP,AC1 ;CLEAR RETURN TO IBS+1
IBSTO1: MOVN AC1,MXLVL(I12) ;NUMBER OF IOWD'S TO ZERO
MOVEI AC2,USOBJ(I12) ;ADR OF FIRST IOWD
HRL AC2,AC1 ;FOR AOBJN
SETZM (AC2) ;
AOBJN AC2,.-1 ;
;BINARY SEARCH ROUTINE FOR THE INDEX BLOCKS
IBS: PUSHJ PP,GETOP ;GET THE TOP LEVEL INDEX BLOCK
JRST .+2
IBS0: PUSHJ PP,GETBLK ;GET THE BLOCK INTO CORE
MOVE AC5,SINC(I12) ;THE SEARCH INCREMENT
HRRZ AC4,@IOWRD0(I12)
SUB AC4,IESIZ(I12) ;INITIALIZE AT ZEROTH ENTRY
ADDI AC4,3 ;ADR OF FIRST WRD OF FIRST ENTRY
MOVE AC6,IBLEN(I12) ;TABLE LEN
ADD AC6,AC4 ;TABLE LIMIT
IBSGE: LSH AC5,-1 ;HALF THE INC
CAMGE AC5,IESIZ(I12) ;BEGINNING OF TABLE?
JRST IBS100 ;YES, DONE
ADD AC4,AC5 ;CURRENT ENTRY PLUS INC
IBS2: MOVE AC10,AC4
ADD AC10,IESIZ(I12)
CAMG AC10,AC6 ;[311] END OF TABLE?
SKIPN (AC10) ;[311] NULL ENTRY?
JRST IBSLT ;YES, GO OTHER WAY
TXNE FLG1,FSTIDX ;[605] SKIP IF NOT 1ST READ SEQ
JRST IBSLT ;[605] ELSE GO DOWN LEFT SIDE TO 1ST DATA REC
JRST @ICMP(I12) ;DO THE COMPARISON
;RETURNS ARE IBSGE OR IBSLT
IBSLT: LSH AC5,-1 ;HALF THE INC
CAMGE AC5,IESIZ(I12) ;BEG OF TABLE?
JRST IBS10 ;YES, DONE
SUB AC4,AC5 ;CURRENT ENTRY MINUS INC
JRST IBS2 ;
IBS100: MOVE AC4,AC10 ;AC10 HAS ENTRY FROM GE
IBS10: MOVEM AC4,@CNTRY0(I12) ;ADR OF CURRENT ENTRY
SETZM @NNTRY0(I12) ;SO 'SREAD' WILL WORK IF IT'S NEXT
SOJG LVL,IBS0 ;GO AGAIN DOWN A LEVEL
JRST DSRCH ;LEVEL ZERO, EXIT SEARCH ROUTINE
;INDEX DISPLAY NON-NUMERIC COMPARE
ICDNN: MOVE AC1,IKWCNT(I12) ;-CNT ,, ADR OF IAK
MOVEI AC2,2(AC10) ;INDEX ENTRY
ICDNN1: MOVE AC0,(AC2) ;INDEX ENTRY
CAME AC0,(AC1) ;RECORD KEY = IDX-KEY
JRST ICDNN2 ;NOT EQUAL
ADDI AC2,1 ;NEXT
AOBJN AC1,ICDNN1 ;LOOP IF YOU CAN
JRST IBSGE ;EQUAL RETURN
ICDNN2: MOVE AC3,(AC1) ;RECORD KEY
TLC AC0,1B18 ;
TLC AC3,1B18 ;
CAMG AC0,AC3 ;
JRST IBSGE ;RECORD KEY GT IDX-KEY
JRST IBSLT ;RECORD KEY LT IDX-KEY
;INDEX COMPARE ONE WORD SIGNED
IC1S: MOVE AC0,@IAKBP(I12) ;RECORD KEY
CAMGE AC0,2(AC10) ;
JRST IBSLT ;RECORD KEY LT IDX-KEY
JRST IBSGE ;RECORD KEY EQ OR GT IDX-KEY
;TWO WORD SIGNED
IC2S: MOVE AC0,@IAKBP(I12) ;SYM-KEY
CAMGE AC0,2(AC10) ;
JRST IBSLT ;RECORD KEY LT IDX-KEY
CAME AC0,2(AC10) ;
JRST IBSGE ;RECORD KEY GT IDX-KEY
MOVE AC0,@IAKBP1(I12) ;NEXT WRD
CAMGE AC0,3(AC10) ;
JRST IBSLT ;SK LT IK
JRST IBSGE ;SK EQ OR GT IK
;ONE WORD UNSIGNED
IC1U: MOVM AC0,@IAKBP(I12) ;SK
MOVM AC1,2(AC10) ;IK
CAMGE AC0,AC1 ;
JRST IBSLT ;SK LT IK
JRST IBSGE ;SK EQ OR GT IK
;TWO WORD UNSIGNED
IC2U: MOVM AC0,@IAKBP(I12) ;SK
MOVM AC1,2(AC10) ;IK
CAMGE AC0,AC1 ;
JRST IBSLT ;SK LT IK
CAME AC0,AC1 ;
JRST IBSGE ;SK GT IK
MOVM AC0,@IAKBP1(I12) ;
MOVM AC1,3(AC10) ;
CAMGE AC0,AC1 ;
JRST IBSLT ;SK LT IK
JRST IBSGE ;SK EQ OR GT IK
;SEACH FOR A DATA FILE KEY
DSRCH: MOVE AC0,(AC4) ;GET THE BLOCK NUMBER
JUMPN AC0,DSRCH1 ;IS IT ZERO ?
TXNN AC16,V%WRITE ;YES, TAKE INVALID KEY EXIT
JRST RRDIV1
JRST IWIVK1 ;NO
DSRCH1: PUSHJ PP,GETBLK ;
PUSHJ PP,SETLRW ;SETUP LRW, POINTER TO LAST FREE RECWRD
LDB AC6,F.BBKF ;NUMBER OF RECS THIS BLK
HRRZ AC4,IOWRD(I12) ;
ADDI AC4,2 ;FIRST WORD, FIRST REC
LDB AC1,RSBP(I12) ;RECSIZ IN CHARS
IDIV AC1,D.BPW(I16) ;
JUMPE AC2,.+2 ;
ADDI AC1,1 ;
JUMPE AC1,DSNUL ;EXIT HERE IF DATA BLOCK IS EMPTY
MOVEI AC5,1(AC1) ;RECSIZ IN WRDS PLUS ONE
ADDI AC5,-1(AC4) ;5 POINTS AT NEXT RECSIZ WRD
TLNE FLG1,SEQ ;A SEQUENTIAL READ?
POPJ PP, ;YES, EXIT HERE
DSLOOP: ADD AC4,DBPRK(I12) ;[276] FIRST KEY,FIRST REC
MOVE AC10,AC4 ;
JRST @DCMP(I12) ; RETURNS TO DSGT, DSEQ OR DSLT
DSGT: HRRZI AC4,1(AC5) ;FIRST WRD NEXT REC
SOJE AC6,DSGT03 ;EXIT IF NO ROOM FOR MORE RECORDS
LDB AC1,RSBP(I12) ;RECSIZ IN CHARS
IDIV AC1,D.BPW(I16) ;
JUMPE AC2,.+2 ;
ADDI AC1,1 ; IN WORDS
MOVEI AC5,1(AC1) ;RECSIZ INWORDS PLUS ONE
ADDI AC5,-1(AC4) ;5 POINTS AT NEXT RECSIZ WORD
SKIPE -1(AC4) ;SKIP IF APPENDING TO THE RECS IN THIS BLK
JRST DSLOOP ;
DSGT01: HRRZI AC4,(AC5)
TXNN AC16,V%WRITE ;LAST REC & NOT FOUND
JRST RRDIVK ;READ, RERIT, DELET INVALID-KEY
JRST DSXIT1 ;THIS WILL BE THE LAST RECORD IN THIS BLOCK
DSGT03: AOJA AC5,DSGT01 ;CNTRY MUST POINT AT RECORD NOT HEADER
DSEQ: TXNE AC16,V%WRITE ;
JRST IWIVK ;WRITE INVALID-KEY
DSXIT: SUB AC4,DBPRK(I12) ;[276] DATA BYTE-POINTER TO RECORD KEY
DSXIT1: MOVEM AC4,CNTRY(I12) ;
;BL; 1 LINE INSERTED AT DSXIT+1 TO FIX START-RETAIN BUG ***************
SKIPN SU.FRF ;DON'T RESET IF RETAIN
SETZM NNTRY(I12) ;SO SREAD WILL GET "NEXT" RECORD
POPJ PP,
;NO RECORDS IN THIS DATA BLOCK
DSNUL: TXNE AC16,V%WRITE ;
JRST DSXIT1
TRNN FLG1,FSTIDX ;[661] DOING FIRST SEQ READ TO BEGIN OF FILE
JRST RRDIVK
POPJ PP, ;[661] YES, RETURN TO BROWSE THRU FILE
;CALL IS: JRST @DCMP(I12)
;RETURNS: DSGT OR DSEQ OR DSLT
;CONVERT NUMERIC DISPLAY TO 1 OR 2 WRD INTEGER
DGD67: MOVE AC0,[XWD AC4, ACSAV0+4] ;
BLT AC0,ACSAV0+16 ;SAVE ACS
HRRM AC10,GDPRK(I12) ;POINT AT CURRENT DATA KEY
MOVE AC16,[Z AC2,GDPRK] ;PARAMETER
ADD AC16,I12 ;INDEX IT
PUSHJ PP,@GDX.D(I12) ;CONVERT, GD6. OR GD7.
MOVE AC0,[XWD ACSAV0+4, AC4] ;
BLT AC0,AC16 ;
MOVEI AC10,2 ;POINT AT CONVERTED DATA
JRST @DCMP1(I12) ;OFF TO COMPARISION ROUTINE
;DATA DISPLAY NON-NUMERIC COMPARE
DCDNN: MOVE AC1,DKWCNT(I12) ;-CNT ,, DAKBP
MOVE AC0,FWMASK(I12) ;FIRST WRD MASK
JUMPE AC0,DCDNN2 ;JUMP ONLY ONE WRD
AND AC0,(AC10) ;REC-KEY
JRST .+2
DCDNN1: MOVE AC0,(AC10) ;REC-KEY
CAME AC0,(AC1) ;
JRST DCDNN3 ;NOT EQ
ADDI AC10,1 ;NEXT
AOBJN AC1,DCDNN1 ;
DCDNN2: MOVE AC0,LWMASK(I12) ;LAST WRD MASK
AND AC0,(AC10) ;
CAMN AC0,(AC1) ;
JRST DSEQ ;RECORD KEY EQ REC-KEY
DCDNN3: MOVE AC3,(AC1) ;
TLC AC0,1B18 ;
TLC AC3,1B18 ;
CAMG AC0,AC3 ;
JRST DSGT ;RECORD KEY GT REC-KEY
; JRST DSLT ;RECORD KEY LT REC-KEY
DSLT: TXNE AC16,V%WRITE ;
JRST DSXIT ;NORMAL IWRITE EXIT
SUB AC4,DBPRK(I12) ;[276] DATA BYTE-POINTER TO RECORD KEY
JRST RRDIVK ;READ, RERIT, DELETE INVALID-KEY
;DATA, ONE WORD SIGNED
DC1S: MOVE AC0,@DAKBP(I12) ;
CAMGE AC0,(AC10) ;
JRST DSLT ;SK LT RK
CAME AC0,(AC10) ;
JRST DSGT ;SK GT RK
JRST DSEQ ;SK EQ RK
;DATA, TWO WRD SIGNED
DC2S: MOVE AC0,@DAKBP(I12) ;
CAMGE AC0,(AC10) ;
JRST DSLT ;SK LT RK
CAME AC0,(AC10) ;
JRST DSGT ;SK GT RK
MOVE AC0,@DAKBP1(I12);
CAMGE AC0,1(AC10) ;
JRST DSLT ;SK LT RK
CAME AC0,1(AC10) ;
JRST DSGT ;SK GT RK
JRST DSEQ ;SK EQ RK
;DATA, ONE WRD UNSIGNED
DC1U: MOVM AC0,@DAKBP(I12) ;
MOVM AC1,(AC10) ;
CAMGE AC0,AC1 ;
JRST DSLT ;SK LT RK
CAME AC0,AC1 ;
JRST DSGT ;SK GT RK
JRST DSEQ ;SK EQ RK
;DATA, TWO WRD UNSIGNED
DC2U: MOVM AC0,@DAKBP(I12) ;
MOVM AC1,(AC10) ;
CAMGE AC0,AC1 ;
JRST DSLT ;SK LT RK
CAME AC0,AC1 ;
JRST DSGT ;SK GT RK
MOVM AC0,@DAKBP1(I12);
MOVM AC1,1(AC10) ;
CAMGE AC0,AC1 ;
JRST DSLT ;SK LT RK
CAME AC0,AC1 ;
JRST DSGT ;SK GT RK
JRST DSEQ ;SK EQ RK
;GET A BLOCK, MAYBE THE TOP-BLOCK & CHECK VERSION NOS
GETOP: MOVE LVL,MXLVL(I12) ;NOTE ITS TOP LVL
SKIPA AC1,TOPIBN(I12) ;THE BLOCK NO.
GETBLK: MOVE AC1,(AC4) ;NEXT BLKNO
MOVE AC2,@IOWRD0(I12) ;CURRENT IOWRD
MOVEM AC2,CMDLST ;SET THE IOWD
CAMN AC1,@USOBJ0(I12) ;IN CORE?
JRST GETB0A ;YES
GETB0E: JUMPE LVL,GETB0C ;JUMP IF DATA FILE
IFN ISTKS,<AOS @INSSS0(I12) ;COUNT THE IN'S >
PUSHJ PP,FIUSI ; DO A FILOP. TYPE USETI
XCT IIN ;[IN CH,CMDLST]
GETB1E: SKIPA AC2,2(AC2) ;GET NEW VERSION NO.
JRST GBIER ;INPUT ERROR
GETB0D: MOVEM AC1,@USOBJ0(I12) ;BLKNO TO USOBJ(I12)
SKIPE LVL ;DATA BLOCK ALWAYS HAS VERSION NO.
CAME AC1,TOPIBN(I12) ;TOPBLOCK HAS NO VERSION NO.
CAMN AC2,1(AC4) ;SAME VERNO?
POPJ PP, ;YES
JRST GETB0B ;VERSION ERROR
;IGNORE THIS INDEX FILE INPUT ERROR?
GBIER: MOVX AC0,E.MINP+E.FIDX+E.BIDX ;NOTE IT WAS AN INPUT ERROR
PUSHJ PP,IGMI ;IGNORE THIS ERROR?
JRST IINER ;NO, GIVE AN ERROR MESSAGE
PUSHJ PP,CLRIS ;YES, CLEAR THE INDEX FILE STATUS BITS
JRST GETB1E ; AND IGNORE THE ERROR.
GETB0A: TLNE FLG1,RIVK!VERR ;FORCE INPUT?
JRST GETB0E ;YEP
JUMPE LVL,GETB0F ;LEVEL 0 IS A DATA FILE
MOVE AC2,2(AC2) ;
CAME AC1,TOPIBN(I12) ;TOP-BLOCK HAS NO VERNO
CAMN AC2,1(AC4) ;
POPJ PP,
GETB0B: MOVEI AC1,@USOBJ0(I12);GET ADR OF THIS LEVEL'S BLOCK #
MOVE AC1,1(AC1) ;GET BLOCK # OF PRECEDING LEVEL
MOVEM AC1,FS.BN ;SAVE THE OFFENDING BLOCK NUMBER
TLNE FLG1,SEQ ;SEQ READ?
JRST UDVERR ;SPECIAL CASE
TLON FLG1,VERR ;FIRST OR SECOND ERROR?
JRST IBSTOP ;FIRST, SO TRY AGAIN
PUSHJ PP,VNDE ;[307] IF TOP BLOCK WAS SPLIT TRY AGAIN
JRST GBVER ;[307] NO - SO ERROR MESSAGE AND QUIT
JRST IBSTOP ;[307] YES - TRY ONE MORE TIME
;IGNORE THIS ERROR?
GBVER: SETOM FS.IF ;IDX FILE
MOVX AC0,E.FIDA+E.BDAT+FE%4 ;ERROR NUMBER
CAIE LVL,0 ;SKIP IF DATA BLOCK
MOVX AC0,E.FIDX+E.BIDX+FE%4 ;ERROR NUMBER
PUSHJ PP,IGCV ;IGNORE ERROR?
JRST GETB0G ;NO -- GIVE A ERROR MESSAGE
POPJ PP, ;YES -- TAKE A NORMAL EXIT
GETB0G: OUTSTR [ASCIZ /Version number discrepancy /]
JRST IINER2 ;
GETB0C: SKIPN LIVE(I12) ;MUST BLOCK BE OUTPUT?
JRST GETB1C ;NO
PUSHJ PP,WWDBK ;YES--DOIT
JRST GETBLK ;
GETB1C: PUSHJ PP,FUSI ; DO A FILOP. TYPE USETI
HRRI AC0,CMDLST
HRRM AC0,UIN.
IFN ISTKS,<AOS @INSSS0(I12) ;COUNT THE IN'S >
XCT UIN.
GETB0F: SKIPA AC2,1(AC2)
JRST GBDER
HLLZS UIN.
HLRZS AC2 ;VERSION NO TO RIGHT HALF
TRZ AC2,-100 ;CLEAR OUT THE FILE FORMAT INFO
JRST GETB0D
;IGNORE DATA FILE IO ERROR?
GBDER: ;[1103]
IFE TOPS20,< ;[1103] TOPS-10 ONLY EOF ERROR FLAG TO TEST
SKIPE SU.FRF ;[1103] DOING FAKE READ, I.E. SMU RETAIN?
PUSHJ PP,GBDEOF ;[1103] YES, GO TEST FOR EOF FLAG FROM IN UUO
JRST GBDER1 ;[1103] TEST IS FALSE, RETURN +1
PUSHJ PP,CLRDS ;[1103] TEST IS TRUE, RETURN +2, GO CLEAR STATUS
JRST GETB0F ;[1103] AND GO RETURN BLOCK = 0, WHICH IS OK
GBDER1: ;[1103]
> ;[1103] END IFE TOPS20
MOVE AC0,[E.MINP+E.FIDA+E.BDAT] ;ERROR NUMBER
PUSHJ PP,IGMD ;IGNORE THE ERROR?
JRST UINER ;NO, GIVE ERROR MESSAGE
PUSHJ PP,CLRDS ;CLEAR DATA FILE STATUS BITS
JRST GETB0F ;YES, TAKE A NORMAL RETURN
;[1103] TEST TOPS-10 EOF ERROR FLAG FROM IN UUO
IFE TOPS20,< ;[1103]
GBDEOF: ;[1103]
PUSH PP,AC2 ;[1103] SAVE CHANNEL INFO FROM IN UUO CALL
XCT UGETS. ;[1103] DO A GETSTS UUO ON CHANNEL
TXNE AC2,IO.ERR ;[1103] REPORTING A REAL I-O ERROR?
JRST GBDEO1 ;[1103] YES, RETURN +1
TXNE AC2,IO.EOF ;[1103] EOF FLAG SET FOR IN UUO?
AOS -1(PP) ;[1103] YES, SET UP TO RETURN +2
GBDEO1: ;[1103]
POP PP,AC2 ;[1103] RESTORE CHANNEL INFO
POPJ PP, ;[1103] AND RETURN
> ;[1103] END IFE TOPS20
;[307] HERE ON "VERSION NUMBER DISCREPANCY ERROR"
;[307] SEE IF THERE ARE MORE INDEX LEVELS THAN THE READER KNOWS ABOUT
;[307] I.E. WHEN A WRITER SPLITS THE TOP BLOCK AND CREATES A NEW
;[307] INDEX LEVEL.
;[307] IF SO GET ANOTHER BUFFER TO ACCOMMODATE THE NEW INDEX LEVEL(S)
;[307] AND TRY AGAIN.
;[307] POPJ IF OPNOUT OR NO NEW INDEX LEVEL OR SORT IN PROGRESS
;[307] OR NO MORE CORE.
;[307] ELSE TAKE A SKIP EXIT -- TRY AGAIN.
VNDE: TLZE FLG1,TRYAGN ;[307] BEEN HERE BEFORE ?
POPJ PP, ;[307] YES - CAN'T HELP
TLO FLG1,TRYAGN ;[307] REMEMBER YOU'VE BEEN HERE
; ENTRY POINT TO READ FRESH COPY OF STS BLOCK
VNDE1: PUSHJ PP,RSTBK ;[307] NO - GET FRESH COPY OF STATISTICS BLOCK
MOVN AC5,MXLVL(I12) ;[307] SEE IF SOMEONE HAS CREATED
SUB AC5,OMXLVL(I12) ;[307] A NEW INDEX LEVEL
JUMPE AC5,RET.1 ;[307] EXIT HERE IF NOT
HRRZ AC1,ISPB(I12) ;[307] BUILD AN IOWRD IN AC6
IMULI AC1,200 ;[307] AND GET THE LENGTH IN AC1
MOVN AC6,AC1 ;[307] --
HRLZS AC6 ;[307] --
HRR AC6,.JBFF ;[307] --
SUBI AC6,1 ;[307] --.
MOVEI AC4,IOWRD+1(I12);[307] GET LOCATION OF THE FIRST
SUB AC4,OMXLVL(I12) ;[307] UNUSED IOWRD POINTER
HRL AC4,AC5 ;[307] # OF NEW IOWRD'S REQUIRED
VNDE10: SKIPE (AC4) ;[307] IF IOWRD ALREADY EXIST
JRST VNDE20 ;[307] TRY TO LOOP
SKIPE KEYCV. ;[307] IF SORT IN PROGRESS
POPJ PP, ;[307] QUIT -- CAN'T HANDLE THAT
HRRZ AC0,AC1 ;[307] LENGTH OF THE BUFFER AREA
PUSHJ PP,GETSPC ;[307] GET SOME SPACE
POPJ PP, ;[307] NONE LEFT
HRRZ AC0,HLOVL. ;SEE IF WE'RE WIPING OUT
CAMGE AC0,.JBFF ; THE OVL-AREA
JUMPN AC0,VNDERR ;COMPLAIN IF WE ARE
MOVEM AC6,(AC4) ;[307] MAKE A NEW IOWRD
ADD AC6,AC1 ;[307] AND SET UP FOR NEXT ONE
VNDE20: AOBJN AC4,VNDE10 ;[307] LOOP IF MORE LEVELS
JRST RET.2 ;[307] TAKE SKIP EXIT + TRY AGAIN
VNDERR: EXCH AC1,.JBFF ;FIRST GET OUT
SUBM AC1,.JBFF ; OF OVL-AREA
MOVEI AC0,FS%30 ;PERMANENT ERROR
MOVEM AC0,FS.FS ;LOAD FILE-STATUS
SETOM FS.IF ;IDX FILE
MOVX AC0,E.FIDX+FE%35 ;IDX-FLAG TOO
PUSHJ PP,OXITP ;DONT RET IF IGNORING ERRORS
XCT WOVLRX ;GIVE MESSAGE
JRST GETB0G ;FINISH UP
;MARK THIS BLOCK SO IT WILL BE OUTPUT
WDBK: SETOM LIVE(I12) ;MARK IT
SKIPE BRISK(I12) ;SKIP IS SLOW BUT SAFE
POPJ PP,
;WRITE A DATA BLOCK
WWDBK: MOVE AC1,USOBJ(I12) ;
MOVE AC0,IOWRD(I12) ;
WWDBK1: MOVEM AC0,CMDLST ;
PUSHJ PP,FUSO ; DO A FILOP. TYPE USETI
MOVEI AC2,CMDLST ;
HRRM AC2,UOUT. ;
SETZM LIVE(I12) ;CLEAR THE LIVE FLAG
AOS IOUUOS(I12) ;
IFN ISTKS,<AOS @OUTSS0(I12) ;COUNT THE OUT'S >
XCT UOUT. ;
JRST .+2 ;
PUSHJ PP,WDBER ;OUTPUT ERROR
HLLZS UOUT. ;
PUSHJ PP,CKFOD ;[523] DO CHECK POINT FILOP.(.FOURB)
;[530] RETURN TO CALLER IF OK
;DATA FILE IO ERROR
WDBER: MOVX AC0,E.MOUT+E.FIDA+E.BDAT ;ERROR NUMBER
PUSHJ PP,IGMD ;IGNORE THIS ERROR?
JRST UOUTER ;NO -- GIVE A ERROR MESSAGE
JRST CLRDS ;YES, CLEAR STATUS BITS
;WRITE AN INDEX BLOCK
WIBK: MOVE AC1,@USOBJ0(I12)
MOVE AC0,@IOWRD0(I12)
IFN ISTKS,<AOS @OUTSS0(I12) ;COUNT THE OUT'S >
WIBK1: MOVEM AC0,CMDLST ;
AOS IOUUOS(I12) ;
PUSHJ PP,FIUSO ; USE FILOP. TYPE USETO
XCT IOUT ;
PUSHJ PP,CKFOI ;[523] DO CHECK POINT FILOP.(.FOURB)
WIBK2: MOVE AC0,CMDLST ; RESTORE AC0
CAMN AC0,IOWRD+13(I12);SAT BLOCK?
MOVX AC0,E.BSAT ;YES
CAMN AC0,IOWRD+14(I12);STATISTICS BLOCK?
MOVX AC0,E.BSTS ;YES
CAIG AC0,0 ;NONE OF THE ABOVE?
MOVX AC0,E.BIDX ;MUST BE INDEX BLOCK
ADD AC0,[E.MOUT+E.FIDX];OUTPUT ERROR
PUSHJ PP,IGMI ;IGNORE ERROR?
JRST IOUTER ;NO
JRST CLRIS ;CLEAR STATUS BITS AND RETURN
;WRITE A SAT BLOCK
WSBK: MOVE AC1,USOBJ+13(I12)
MOVE AC0,IOWRD+13(I12)
IFN ISTKS,<AOS OUTSSS+13(I12) ;COUNT THE OUT'S >
JRST WIBK1 ;
;WRITE AUXILARY BLOCK
WABK: MOVE AC1,AUXBNO
MOVE AC0,AUXIOW
HLL AC0,IOWRD(I12)
JUMPE LVL,WWDBK1
HLL AC0,IOWRD+1(I12)
IFN ISTKS,<AOS @OUTSS0(I12) ;COUNT THE OUT'S >
JRST WIBK1
;WRITE STATISTICS BLOCK
WSTBK: MOVEI AC1,1
MOVE AC0,IOWRD+14(I12)
IFN ISTKS,<AOS OUTSSS+14(I12) ;COUNT THE OUT'S >
JRST WIBK1
;READ A STATISTICS BLOCK
RSTBK: MOVEI AC1,1 ;[307]
MOVE AC2,IOWRD+14(I12) ;[307]
MOVEM AC2,CMDLST ;[307]
PUSHJ PP,FIUSI ; USE FILOP. TYPE USETI
IFN ISTKS,<AOS INSSSS+14(I12) ;COUNT THE IN'S >
XCT IIN ;[307]
POPJ PP, ;[307]
MOVX AC0,E.MINP+E.FIDX+E.BSTS ;ERROR NUMBER
PUSHJ PP,IGMI4 ;IGNORE THE ERROR?
JRST RSTBK1 ;NO
PUSHJ PP,CLRIS ;CLEAR STATUS BITS
TXNE AC16,V%READ ;IF NOT IREAD OR SREAD
AOS (PP) ; SKIP EXIT
POPJ PP,
RSTBK1: OUTSTR [ASCIZ /Cannot read statistics block./] ;[307]
JRST IINER ;[307]
;READ A SAT BLOCK
RSBK: MOVEM AC1,USOBJ+13(I12)
MOVE AC2,IOWRD+13(I12)
MOVEM AC2,CMDLST
AOS IOUUOS(I12)
PUSHJ PP,FIUSI ; USE FILOP. TYPE USETI
IFN ISTKS,<AOS INSSSS+13(I12) ;COUNT THE IN'S >
XCT IIN
POPJ PP,
MOVX AC0,E.MINP+E.FIDX+E.BSAT ;ERROR NUMBER
PUSHJ PP,IGMI2 ;IGNORE ERROR?
JRST RSBK1 ;NO
PUSHJ PP,CLRIS ;CLEAR STATUS BITS
JRST RET.2 ;TAKE A NORMAL EXIT
RSBK1: OUTSTR [ASCIZ /Cannot read sat block./]
JRST IINER
;ROUTINE TO CLEAR INDEX FILE ERROR STATUS BITS
CLRIS: PUSH PP,AC2 ;SAVE AC2
XCT IGETS ;GET STATUS TO AC2
TXZ AC2,IO.ERR ;TURN EM OFF
XCT ISETS ; AND RESET THEM
CLRIS1: POP PP,AC2 ;
POPJ PP, ;
;ROUTINE TO CLEAR DATA FILE ERROR STATUS BITS
CLRDS: PUSH PP,AC2 ;SAVE AC2
XCT UGETS. ;GET STATUS TO AC2
TXZ AC2,IO.ERR ;TURN EM OFF
XCT USETS. ; AND RESET THEM
JRST CLRIS1
;MOVE BUFFER TO RECORD (READ)
MOVBR: HRRZ AC0,D.RFLG(I16) ; GET SOME FLAGS
TRZE AC0,SAVNXT ; CLEAR FLAG FOR NXT REC POS SAVED
HRRM AC0,D.RFLG(I16) ; Put IT BACK
LDB AC0,F.BMRS ;MAX-REC-SIZ
MOVEM AC0,D.CLRR(I16) ;SAVE LENGTH
MOVE AC6,RECBP(I12) ;REC BYTE-POINTER
HRRZ AC4,CNTRY(I12) ;[V10] POINTER TO DATA.
HRRZ AC3,-1(AC4)
TLNN FLG,DDMASC ;ASCII ?
JRST MOVBR1 ;NO
LSH AC3,-1 ;
SUBI AC3,2 ;<CRLF>
MOVBR1: ANDI AC3,7777
CAML AC0,AC3 ;[613]
JRST MOVB1A ;[613] REC SIZE OK
PUSHJ PP,ERRMR0 ; THE RECORD SIZE IS TOO BIG!
;[613] PRINT WARNING THAT RECORD LENGTH FIELD (SIXBIT OR V FORMAT)
;[613] IS LARGER THAN FD MAXIMUM
OUTSTR [ASCIZ/%Record length field larger than FD maximum, assuming max.
/]
; AC3 LOADED WITH MAX SIZE IN ERRMR0
MOVB1A: MOVEM AC3,D.CLRR(I16) ;[613] UPDATE WITH LENGTH READ
TLNN FLG,CONNEC!DDMASC!DDMBIN
JRST BLTBR ; EBCDIC OR SIXBIT, BLTIT
LDB AC10,[POINT 2,FLG,2] ; GET DEVICE DATA MODE
HLL AC4,RBPTB1(AC10) ; GET BYTE PTR
MOVE AC10,D.RCNV(I16) ; SET AC10
SUBI AC0,(AC3) ;[335] KEEP TRACK OF NEEDED BLANK FILL
MOVB0A: ILDB C,AC4
XCT AC10
JUMPLE C,MOVB0A ;IGNOR LEADING EOLS & NULLS
MOVB0B: IDPB C,AC6
SOJE AC3,MOVB0C ;[335] DONT RETURN TILL CHECK FILL
ILDB C,AC4
XCT AC10
JUMPGE C,MOVB0B ;MOVE THE RECORD
MOVB0C: LDB C,[POINT 2,FLG,14]; GET CORE DATA MODE
MOVE C,SPCTB1(C) ; GET A SPACE CHAR
ADD AC3,AC0 ;[335] #LEFT+ MAX - THIS REC
SKIPE AC3 ;[335] COULD BE NOTHING LEFT TO DO
IDPB C,AC6
SOJG AC3,.-1 ;FILL WITH SPACES
; IF SEQUENTAIL READ CALL @GETSET TO COPY KEY FOR CNTRY INTO
; DAKBP AND IAKBP POSITIONS, SO THAT REWRITE OR DELETE FOLLOWING
; WILL HAVE THE CURRENT KEY TO SAVE
MOVBXT: TXNN AC16,V%STRT ; Is this a call from START?
JRST MOVBXX ; No
PUSHJ PP,@GETSET(I12) ; YES, COPY CNTRY KEY
POPJ PP, ; And return now to START
MOVBXX: TLNE FLG1,SEQ ; IS THIS A SEQUENTIAL READ?
PUSHJ PP,@GETSET(I12) ; YES, COPY CNTRY KEY
;[1064] SKIPE F.WSMU(I16) ; SIMULTANEOUS - UPDATE?
;[1064] PUSHJ PP,LRDEQX## ; YES
LDB AC0,F.BCRC ; GET CHP=PNT REC CNT
JUMPE AC0,MVBXAA ; SKIP IF NONE
TXNE AC16,V%DLT+V%RWRT+V%WRITE+V%WADV ; IS THIS DELET,RERIT,WRITE?
PUSHJ PP,CKPREC ; YES, DECR. COUNT AND CHKPNT IF TIME
MVBXAA: PUSHJ PP,CHKRRN ; CHECK FOR RERUN DUMP
SKIPN F.WSMU(I16) ;[1064] SIMULTANEOUS - UPDATE?
JRST MVBXAC ;[1064] NO
SKIPN SU.FRF ;[1064] DOING FAKE READ FOR SMU?
PUSHJ PP,LRDEQX## ;[1064] NO
MVBXAC:
MOVEI AC1,RDLAST ; SET READ LAST IO OPERATION
IORM AC1,D.RFLG(I16)
JRST CLRSTS ;SET STATUS TO 00 AND POPJ
;BLT BUFFER TO RECORD
BLTBR: CAIN AC0,(AC3) ;[335] IF RECS =
JRST BLTB1 ;[335] NO NEED FOR FILL
IDIV AC0,D.BPW(I16) ; CONVERT TO WORDS
SKIPE AC1 ; ROUND UP?
ADDI AC0,1 ; YES
MOVEI AC1,1(AC6) ;[335] BLT TO
HRLI AC1,(AC6) ;[335] BLT FROM
LDB AC2,[POINT 2,FLG,14] ; GET CORE DATA MODE
MOVE AC2,SPCTBL(AC2) ; AND A WORD OF SPACES
MOVEM AC2,(AC6) ; START BLANK
ADDI AC0,-1(AC6) ;[335]BLT LIMIT
MOVE AC2,AC0 ;[335]
BLT AC1,(AC2) ;[335]ZAP
BLTB1: HRRZ AC1,-1(AC4) ;RECSIZ
;ANDI AC1,7777
IDIV AC1,D.BPW(I16) ; IN WORDS
HRRI AC0, (AC6) ;[V10] TO LOCATION.
ADDI AC6, (AC1) ;[V10] UPDATE THE BYTE POINTER.
JUMPE AC1, BLTB4 ;[V10] IF THERE IS NOTHING TO
;[V10] BLT, GO ON.
HRLI AC0, (AC4) ;[V10] FROM LOCATION.
BLT AC0, -1(AC6) ;[V10] DO IT TO IT.
BLTB4: JUMPE AC2, MOVBXT ;[V10] IF THERE IS NOTHING LEFT
;[V10] OVER, GO ON.
ADDI AC4, (AC1) ;[V10] CONSTRUCT THE SENDING
HLL AC4, AC6 ;[V10] BYTE POINTER.
BLTB6: ILDB C, AC4 ;[V10] TRANSFER THE REST OF THE
IDPB C, AC6 ;[V10] CHARACTERS.
SOJG AC2, BLTB6 ;[V10]
JRST MOVBXT
;MOVE RECORD TO AUXBUF (WRITE)
;BUT FIRST CLEAR BIT-35 IF DEVICE DATA MODE IS ASCII
;SO THE KEY COMPARISION ROUTINES WILL WORK
MOVRBA: TLNN FLG,DDMASC ;IS DATA FILE IS ASCII?
JRST MOVRB0 ;NO
LDB AC0,WOPRS. ;GET RECORD SIZE
ADDI AC0,2+4 ;PLUS 2 FOR CRLF AND 4 TO ROUND UP
IDIVI AC0,5 ;CONVERT TO WORDS
MOVN AC1,AC0 ;MAKE A
HRLS AC1 ; AOBJN
HRR AC1,TEMP.2 ; POINTER
SETZM (AC1) ;CLEAR BIT 35
AOBJN AC1,.-1 ;LOOP
MOVRB0: SKIPA AC5,TEMP.2 ;POINTER TO AUXBUF
;MOVE RECORD TO BUFFER
MOVRB: MOVE AC5,CNTRY(I12) ;POINTER TO BUFFER
LDB AC0,F.BMRS ;MAX-REC-SIZ
MOVE AC6,RECBP(I12) ;REC BYTE-POINTER
LDB AC3,WOPRS. ;
JUMPE AC3,MVRB00 ;NO TEST IF ZERO
CAML AC0,AC3 ;[613] IS RECORD LEGAL SIZE?
JRST MVRB0 ;[613] YES CONT
PUSHJ PP,ERRMR0 ;NO -- TOO BIG
;[613] PRINT WARNING THAT RECORD LENGTH FIELD (SIXBIT OR V FORMAT)
;[613] IS LARGER THAN FD MAXIMUM
OUTSTR [ASCIZ/%Record length field larger than FD maximum, assuming max.
/]
; AC3 LOADED WITH MAX SIZE IN ERRMR0
MVRB0: LDB AC0,F.BLRS ;LOAD MINIMUM SIZE
CAMG AC0,AC3 ;IS RECORD LESS THAN MINIMUM
JRST MVRB00 ;NO
PUSHJ PP,ERRLR2 ;ERROR MESSAGE
;PRINT WARNING THAT RECORD LENGTH FIELD (SIXBIT OR V FORMAT)
;IS SMALLER THAN FD MINIMUM
OUTSTR [ASCIZ/%Record length field smaller than FD minimum.
/]
MVRB00: TLNN FLG,CONNEC!DDMASC!DDMBIN ;[613]
JRST BLTRB ; EBCDIC OR SIXBIT - BLTIT
LDB AC10,[POINT 2,FLG,2] ; GET DEVICE DATA MODE
HLL AC5,RBPTB1(AC10) ; GET BYTE PTR
MOVE AC10,D.WCNV(I16);SET AC10
MOVR0A: ILDB C,AC6 ;
XCT AC10 ;
IDPB C,AC5 ;
SOJG AC3,MOVR0A ;
JUMPGE FLG,RET.1 ;IF NOT ASCII EXIT
PUSHJ PP,RANCR ;
JRST RANLF ;<CRLF> AND EXIT
BLTRB: MOVE AC1,AC3 ;DONT DESTRY 4
IDIV AC1,D.BPW(I16) ; GET BYTES PER WORD
JUMPE AC2,.+2 ;
ADDI AC1,1 ;
HRLI AC0,(AC6) ;FROM
HRRI AC0,(AC5) ;TO
ADDI AC1,-1(AC5) ;UNTIL
BLT AC0,(AC1) ;
POPJ PP,
;IWRITE - SO MAKE HOLE FOR REC TO FIT IN
SHFHOL: SETZ AC3, ;FAKE AN OLD SIZE OF ZERO
LDB AC1,WOPRS. ;NEW-SIZ
JUMPGE FLG,.+2 ;ASCII REC?
ADDI AC1,2 ;YES, ACCOUNT FOR <CRLF>
MOVE AC4,CNTRY(I12) ;POINT AT CURRENT REC
JRST SHFR10 ;
;SHUFFLE RECORDS SO NEXT RECORD WILL JUST FIT
SHFREC: MOVE AC4,CNTRY(I12) ;CURRENT REC
LDB AC1,RSBP(I12) ;OLD RECSIZ IN CHARS
LDB AC3,WOPRS. ;NEW RECSIZ IN CHARS
JUMPGE FLG,SHFR03 ;
ADDI AC3,2 ;ASCII AND WRITE OR RERIT, ADD 2 FOR <CRLF>
SHFR03: TXNE AC16,V%DLT ;DELET?
JRST SHFR04 ;YES
CAMN AC3,AC1 ;SAME SIZE ?
POPJ PP, ;YES
SHFR04: IDIV AC1,D.BPW(I16) ;
JUMPE AC2,.+2 ;
ADDI AC1,1 ;
ADDI AC1,1 ;
EXCH AC1,AC3 ;AC3 = OLD SIZ IN WRDS
SHFR10: TXNE AC16,V%DLT ;DELETING?
JRST SHFR20 ;YES
TXNN AC16,V%WADV!V%WRITE ;IWRITE GETS A COMPLETE NEW HEADER WRD
DPB AC1,RSBP(I12) ;UPDATE RECSIZ
IDIV AC1,D.BPW(I16) ;
JUMPE AC2,.+2 ;
ADDI AC1,1 ;
ADDI AC1,1 ;AC1 = NEW SIZ IN WRDS
SUB AC1,AC3 ;AC1 = DIFF
SHFR11: ADDM AC1,LRW(I12) ;UPDATE LRW
HRRO AC2,LRW(I12) ;
JUMPL AC1,SHFR01 ;BLTIT - MAKE A SMALLER HOLE
SUB AC2,AC1 ;FROM
HRRZ AC0,AC2 ;
SUBI AC0,-1(AC4) ;LEN + OLD-REC-SIZ
SUB AC0,AC3 ;LEN
JUMPLE AC0,RET.1 ;ZERO = OLD-REC IS LAST-REC (ALSO FOR NEG LEN)
ADDI AC0,1 ;MOVE THE HEADER WRD ALSO
;AC0=LEN, AC1=DISPLACEMENT, AC2=-1,,FROM
SHFR00: MOVE AC4,AC1 ;POPIT - MAKE LARGER
ADD AC4,[POP AC2,(AC2)]
MOVE AC5,[SOJG AC0,AC4]
MOVE AC6,[JRST SHFR30] ;[600]
JRST AC4
;SHRINK THE OLD RECORD SIZE
SHFR01: ADDI AC3,-1(AC4) ;FROM
HRL AC3,AC3 ;FROM,AC3 ;FROM,,FROM
ADD AC3,AC1 ;FROM,,TO
MOVE AC1,LRW(I12) ;UNTIL
BLT AC3,(AC1) ;
SHFR30: HRRZ AC2,LRW(I12) ;[600] GET LAST RECORD WORD
SKIPLE D.RCL(I16) ;[600] NOT IF LAST RECORD
SETZM 1(AC2) ;[600] OTHERWISE, ZERO NEXT WORD
POPJ PP,
;SETUP TO DELETE A REC
SHFR20: MOVNI AC1,(AC3) ;RECSIZ + HEADER
MOVE AC5,LRW(I12) ;[1034] SAVE OLD LRW
ADDM AC1,LRW(I12) ;UPDATE LRW
SETOM NNTRY(I12) ;NOTE: CNTRY POINTS AT NEXT ENTRY
PUSHJ PP,SHFR01 ;MOVIT
HRRZ AC2,LRW(I12)
SETZM 1(AC2) ;ZERO RECSIZ MEANS END OF DATA
MOVEI AC3,1(AC2) ;[1034] SET UP SOURCE
HRL AC3,AC3 ;[1034]
ADDI AC3,1 ;[1034] ADJUST DESTINATION
BLT AC3,(AC5) ;[1034] ZERO UNUSED BLOCK AREA
POPJ PP,
;SET POINTER TO LAST FREE RECORD WORD
SETLRW: LDB AC6,F.BBKF ;NUMBER OF RECS PER BLOCK
HRRZ AC4,IOWRD(I12) ;
ADDI AC4,1 ;POINT AT REC-CNT
HRRZ AC5,D.BPW(I16) ;BYTES PER WORD
MOVE AC11,DRTAB ;WHERE TO STORE REC-ORIGN
SUBI AC11,1 ;SET UP FOR PUSH
HLRZ AC0,(AC4) ;VERSION NUMBER
ADDI AC0,1 ; BUMP IT
SETLR1: LDB AC1,RSBP1(I12) ;RECSIZ IN CHARS
JUMPE AC1,SETLR2 ;ZERO RECSIZ IMPLIES LAST REC
ADDI AC1,-1(AC5) ;CONVERT TO WORDS AND
IDIV AC1,AC5 ; ROUND UP
HRL AC3,AC1 ;RECNT IN WORDS
HRR AC3,AC4 ;LOC OF REC-ORIGN
PUSH AC11,AC3 ;PUSH IT IN THE DR-TABLE
TLNE FLG1,BVN ;SPLITTING?
DPB AC0,[POINT 6,(AC4),17] ;VERSION NUMBER IS SIX BITS WIDE
ADDI AC4,1(AC1) ;PLUS ONE FOR RECSIZ
SOJG AC6,SETLR1 ;MORE RECORDS?
SETLR2: MOVEM AC6,D.RCL(I16) ;NO, ROOM FOR <N> RECS
HRROM AC4,AC3 ;TERMINATOR (-1,,LRW+1)
PUSH AC11,AC3 ;
SUBI AC4,1 ;
MOVEM AC4,LRW(I12) ;SAVIT
POPJ PP,
;SET THE INDEX CHANNEL NUMBER
SETIC: HLRZ I12,D.BL(I16) ;INDEX TABLE
MOVE LVL,MXLVL(I12) ;SET LVL TO TOP-LEVEL
MOVE AC5,ICHAN(I12) ;
MOVEI AC10,LASTIC ;
MOVE AC1,[POINT 4,FRSTIC,12]
DPB AC5,AC1 ;
CAIE AC10,(AC1) ;
AOJA AC1,.-2 ;
POPJ PP, ;
;ALLOCATE DATA BLOCKS HERE
;BLOCK NUMBER IS RETURNED IN NEWBK1 & NEWBK2
ALC2BK: TLZ FLG1,TRYAGN ;[307] INIT THIS FLAG
TLO FLG1,BLK2 ;REMEMBER TO GRAB 2 BLOCKS
MOVE AC2,IOWRD+13(I12) ;
ADD AC2,[XWD 2,2] ;
HRRZM AC2,TEMP. ;FIRST WORD OF SAT BITS
SKIPE USOBJ+13(I12) ;IS THERE A SAT BLK INCORE?
JRST ALC05 ;YES
ALC01: TLZE FLG1,WSB ;SHLD SAT BLK BE WRITTEN?
PUSHJ PP,WSBK ;YES
MOVE AC1,SBLOC(I12) ;LOC OF FIRST SAT BLK
ALC02: PUSHJ PP,RSBK ;GET A SAT BLK
;NOW FIND A WORD WITH SOME EMPTY BLOCKS IN IT
ADD AC2,[XWD 2,2] ;FIRST WORD OF SAT BITS
HRRZM AC2,TEMP. ;FIRST-WRD SAVE FOR LATER
ALC05: HRROI AC0,-1 ;WHAT WERE NOT LOOKING FOR
CAMN AC0,(AC2) ;ANY FREE BLOCKS?
AOBJN AC2,.-1 ;NO, LOOP IF MORE WORDS
JUMPL AC2,ALC07 ;[271] JUMP IF FOUND
;THAT BLOCK WAS FULL, TRY NEXT ONE
TLNN FLG1,TRYAGN ;HAVE WE LOOKED FROM THE BEGINNING?
JRST ALC20 ;NO, SO DOIT
MOVE AC0,SBTOT(I12) ;[271] # OF SAT BLOCKS
SUBI AC0,1 ;[271] ADJUST COUNT
IMUL AC0,ISPB(I12) ;[271] TIMES # SECTORS / SAT
ADD AC0,SBLOC(I12) ;[271] PLUS FIRST BLOCK #
CAMG AC0,USOBJ+13(I12) ;IS THERE A NEXT ONE?
JRST ALC20 ;NO, TRY AGAIN, SEE IF ANY WERE DELETED
TLZE FLG1,WSB ;[310] WRITE OUT THE SAT-BLK?
PUSHJ PP,WSBK ;YES
MOVE AC1,ISPB(I12) ;[271] SECTORS / SAT
ADDB AC1,USOBJ+13(I12) ;[271] NEW USETI/O POINTER
JRST ALC02 ;YES, TRY NEXT SAT BLOCK
;FOUND A BLK - FLAG IT IN USE
ALC07: SETCM AC0,(AC2) ;SO JFFO WILL WORK
JFFO AC0,ALC08 ;FIND THE BIT
JRST ALC05 ;TRY NEXT WORD
ALC08: MOVSI AC0,400000 ;
MOVNS AC1 ;
LSH AC0,(AC1) ;
ORM AC0,(AC2) ;FLAG IT IN USE
;OK - WHATS THE BLOCK NUMBER?
HRRZ AC0,AC2 ;
SUB AC0,TEMP. ;
IMULI AC0,^D36 ;
SUB AC0,AC1 ;
ADDI AC0,1 ;
MOVE AC1,USOBJ+13(I12)
SUB AC1,SBLOC(I12) ;
PUSH PP,AC2 ;[271] NEED TO SAVE AC2
IDIV AC1,ISPB(I12) ;[271] / NUMBER OF SECTORS PER SAT
POP PP,AC2 ;[271] ...
IMUL AC1,BPSB(I12) ;
ADD AC0,AC1 ;AC0 HAS THE LOGICAL BLKNO
MOVE AC1,D.BPL(I16) ;BUFFERS PER LOGICAL BLOCK
SUBI AC0,1 ;MINUS ONE
IMUL AC0,AC1 ;TIMES LOGICAL-BLOCK NUMBER
ADDI AC0,1 ; IS USETO OBJECT
TLO FLG1,WSB ;REMEMBER TO WRITE THE SAT BLOCK
MOVEM AC0,NEWBK1 ;SAV THE FIRST BLKNO
TLZN FLG1,BLK2 ;A TWO BLOCK REQ?
JRST WSBK ;ALLOCATE! WRITE OUT THE SAT BLOCK
MOVEM AC0,NEWBK2 ;
JRST ALC07 ;GO FOR NEXT ONE
;START AT BEGINNING AND SEE IF ANY WERE DELETED
ALC20: TLON FLG1,TRYAGN ;FIRST RETRY?
JRST ALC01 ;YES, TRY AGAIN
SETOM FS.IF ;IDX FILE
MOVX AC0,E.FIDX+E.BSAT+FE%5 ;ERROR NUMBER
PUSHJ PP,IGCVR1 ;IGNORE ERROR?
JRST RET.2 ;YES, RETURN TO CBL-PRGM.
OUTSTR [ASCIZ /Allocation failure, all blocks are in-use./]
JRST IOUTE1 ;& KILL
;DE-ALLOCATE BLOCK NUMBER FOUND IN OLDBK
DALC: MOVE AC1,OLDBK ;
IDIV AC1,D.BPL(I16) ;CONVERT PHYSICAL TO LOGICAL BLKNO
SKIPE AC2 ;REMAINDER?
ADDI AC1,1 ;YEP
IDIV AC1,BPSB(I12) ;FIND WHICH RELATIVE SATBLK IT'S IN
IMUL AC1,ISPB(I12) ;[271] TIMES SECTORS / SAT
ADD AC1,SBLOC(I12) ;ABSOLUTE
MOVEM AC2,AC3 ;SAVE RELATIVE BIT POSITION IN SATBLK
CAME AC1,USOBJ+13(I12) ;IS IT IN CORE?
PUSHJ PP,RSBK ;NO,GO GET IT
MOVEM AC1,USOBJ+13(I12) ;MAKE THIS BLK CURRENT
IDIVI AC3,^D36 ;RELATIVE WORD POSITION
ADD AC3,IOWRD+13(I12) ;ABSOLUTE WORD POSITION -2
MOVN AC4,AC4 ;ROTATE TO THE RIGHT
MOVEI AC0,1 ;THE MASK
ROT AC0,(AC4) ;
SKIPN AC4 ;IF REMAINDER = 0
SUBI AC3,1 ; BACKUP A WORD
ANDCAM AC0,2(AC3) ;MARK IT FREE
TLZ FLG1,WSB
SETZM OLDBK ;
JRST WSBK
;SETUP RECORD HEADER WORD
SRHW: MOVE AC4,CNTRY(I12)
MOVE AC1,IOWRD(I12)
MOVE AC1,1(AC1)
MOVEM AC1,-1(AC4) ;SET VERSION NUMBER & BIT35
LDB AC1,WOPRS.
JUMPGE FLG,SRHW1 ;ASCII?
ADDI AC1,2 ;ADD 2 FOR CR + LF
MOVEI AC0,1 ;ASCII FLAG, BIT 35
ORM AC0,-1(AC4) ;
SRHW1: DPB AC1,RSBP(I12) ;THE RECORD SIZE IN CHARS
POPJ PP,
;LOW-VALUE TEST FOR ISAM FILE
;POPJ IF RECORD KEY = LOW-VALUES, SKIP EXIT IF NOT
LVTST: HLRZ I12,D.BL(I16) ;SETUP I12
TXC AC16,V%READ!V%RNXT ;READ NEXT RECORD?
TXCN AC16,V%READ!V%RNXT
POPJ PP, ;YES, THEN ITS SEQUENTIAL
LDB AC1,F.BFAM ;GET ACCESS MODE
TXNE AC16,V%READ ;READ?
JUMPE AC1,RET.1 ;SEQUENTIAL BY DEFINITION
MOVE AC1,F.WBSK(I16) ;SK BYTE-POINTER
LDB AC3,KY.TYP ; GET KEY TYPE
CAIGE AC3,3 ;DISPLAY ?
JRST LVTS02 ;YES
CAIL AC3,7 ; COMP-3?
JRST LVC3 ; YES
LVTS01: CAIG AC3,6 ; COMP-3 IS SAME AS FIXED-POINT
CAIG AC3,4 ;FIXED POINT ?
SKIPA AC2,[1B0] ;YES, LOW-VALUE
MOVE AC2,[1B0+1] ;FLOATING PT. LOW-VALUE
CAME AC2,(AC1) ;LOW-VALUE ?
AOSA (PP) ;NO, SKIP RETURN
TRNE AC3,1 ;TWO WORDS ?
POPJ PP, ;NO, EXIT
CAME AC2,1(AC1) ;LV ?
AOS (PP) ;NO, SKIP RETURN
POPJ PP, ;LV.
LVTS02: LDB AC2,KY.SIZ ; GET KEY SIZE
LVTS03: ILDB AC0,AC1
JUMPN AC0,RET.2 ;NOT LV
SOJG AC2,LVTS03
POPJ PP, ;LOW-VALUE
;ENTRY FOR INDEX-KEY LOW-VALUE TEST
LVTSTI: ADDI AC1,2 ;SKIP OVER THE TWO WORD HEADER
LDB AC3,KY.TYP ; GET KEY TYPE
JUMPE AC3,LVTS02 ;DISPLAY EXITS HERE
JRST LVTS01 ;NUMERIC DISPLAY IS NUMERIC IN THE INDEX
; LV TEST FOR COMP-3
LVC3: LDB AC3,KY.SIZ ; GET KEY SIZE
MOVEI AC2,2(AC3) ; ROUND UP AND GET NUMBER
LSH AC2,-1 ; OF NINE BIT BYTES
LDB AC0,KY.SGN ; SKIP IF A SIGNED KEY
JUMPN AC0,LVC310 ; JUMP IF NOT SIGNED
; HERE IF A SIGNED COMP3
; LOW-VALUES = A STRING OF 9'S FOLLOWED BY A SIGN
SOJE AC2,LVC302 ; JUMP IF ONLY ONE BYTE
ILDB AC0,AC1 ; GET FIRST TWO DIGITS
TLNN AC3,1 ; IF ONLY ONE DIGIT IN THIS BYTE
DPB AC0,[POINT 4,AC0,31]; DUPLICATE IT
JRST .+2 ; SKIP INTO MAIN LOOP
LVC301: ILDB AC0,AC1 ; GET NEXT TWO DIGITS
CAIE AC0,9B31+9B35 ; LOW-VALUES?
JRST RET.2 ; NO EXIT
SOJG AC2,LVC301 ; LOOP
LVC302: ILDB AC0,AC1 ; GET THE LAST BYTE
CAIE AC0,9B31+15B35 ; 9 AND MINUS SIGN?
CAIN AC0,9B31+13B35 ; THERE ARE TWO MINUS SIGNS
POPJ PP, ; LOW-VALUE RETURN
JRST RET.2 ; NOT LV RET
; HERE IF A UNSIGNED COMP3
; LOW-VALUES = A STRING OF 0'S FOLLOWED BY A SIGN
LVC310: SOJE AC2,LVC312 ; JUMP IF ONLY ONE BYTE
TLNN AC3,1 ; IF ONLY ONE DIGIT IN THIS BYTE
JRST LVC311 ; SKIP INTO MAIN LOOP
ILDB AC0,AC1 ; GET FIRST TWO DIGITS
TRZA AC0,360 ; ZERO LEADING DIGIT
LVC311: ILDB AC0,AC1 ; GET NEXT TWO DIGITS
JUMPN AC0,RET.2 ; JUMP IF NOT LV
SOJG AC2,LVC311 ; LOOP
LVC312: ILDB AC0,AC1 ; GET THE LAST BYTE
TRZ AC0,17 ; FORGET ABOUT THE SIGN
JUMPN AC0,RET.2 ; JUMP IF NOT LV
POPJ PP, ; LOW-VALUE RETURN
;INDEX FILE INPUT ERROR
IINER: XCT IGETS ;GET STATUS TO AC2
TXNE AC2,IO.EOF ;EOF?
OUTSTR [ASCIZ /Found an EOF instead of index block./]
IINER1: MOVE LVL,D.DC(I16) ;DEV CHARACTERISTICS
PUSHJ PP,IOERM1 ;NO, CHECK THE OTHERS
IINER2: MOVE AC2,[BYTE (5)10,31,20,21,4]
PUSHJ PP,MSOUT. ;FILE CANNOT DO INPUT & KILL
;DATA FILE INPUT ERROR
UINER: XCT UGETS. ;ERROR BITS
TXNE AC2,IO.EOF ;EOF?
OUTSTR [ASCIZ /Found an EOF instead of data block./]
JRST IINER1 ;MESSAGE AND KILL
LVSKER: TXNE AC16,V%RWRT
OUTSTR [ASCIZ /REWRITE, /]
TXNE AC16,V%DLT
OUTSTR [ASCIZ /DELETE, /]
TXNE AC16,V%WRITE
OUTSTR [ASCIZ /WRITE, /]
OUTSTR [ASCIZ /RECORD KEY must not equal LOW-VALUES./]
HRLZI AC2,(BYTE (5) 10,31,20)
PUSHJ PP,MSOUT. ;KILL & DON'T RETURN
;SEE IF THIS MESSAGE SHOULD BE IGNORED
LVERR: SETOM FS.IF ;IDX FILE
MOVX AC0,E.FIDX+FE%1 ;LOW-VALUES ILLEGAL
PUSHJ PP,IGCV ;FATAL ERROR OR IGNORE ERROR?
JRST LVSKER ;FATAL!
JRST RET.2 ;DONT PROCESS THIS VERB
;JUST RETURN TO CBL-PRGM
;INDEX FILE OUTPUT ERROR
IOUTER: XCT IWAIT
XCT IGETS
TXNN AC2,IO.ERR
POPJ PP, ;NO ERRORS SO EXIT
MOVE LVL,D.DC(I16) ;DEV-CHAR
PUSHJ PP,IOERM1
IOUTE1: MOVE AC2,[BYTE (5) 10,31,20,22,4]
PUSHJ PP,MSOUT. ;& KILL
;DATA FILE OUTPUT ERROR
UOUTER: XCT UWAIT.
MOVE LVL,D.DC(I16) ;DEVICE CHARACTERISTICS
PUSHJ PP,IOERMS
MOVE AC2,[BYTE (5) 10,36,31,20,4]
JRST MSOUT. ;MESSAGE AND KILL
; CKPREC ROUTINE TO CHECK FOR CHECKPOINT ON RECORD COUNT
;
; RETURNS +1 ALWAYS
;
; USES AC0,AC1
CKPREC: SOSE D.CRC(I16) ; DECREMENT COUNT AND SKIP IF TIME TO DO IT
POPJ PP, ; NOT NOW, RETURN
LDB AC0,F.BCRC ; GET COUNT
MOVEM AC0,D.CRC(I16) ; RESET IT
TLNN FLG,IDXFIL ;[1016] SKIP IF ISAM FILE
TLNN FLG,RANFIL+IOFIL ; DUMP MODE FILE?
JRST CPREC1 ; NO, CONT
; DUMP MODE FILES MUST OUTPUT PARTIAL BUFFER BEFORE CHK-PNT
MOVE AC1,D.CBN(I16) ; GET CURRENT BLOCK NUMBER
PUSHJ PP,RANOUT ; DUMP CURRENT BUFFER (MAYBE PARTIAL)
HLLZS UOUT. ;[1036] ZERO RIGHT HALF
; NOW RESET BACK TO LAST POSITION BEFORE DOING CHK-PNT
MOVE AC1,D.CBN(I16) ; CURRENT BLOCK
PUSHJ PP,FUSO ; DO A FILOP. TYPE USETO
CPREC1: LDB AC0,DTCN. ; GET CHANNEL FOR DATA FILE
PUSHJ PP,CHKPNT ; DO CHECKPOINT
TLNN FLG,IDXFIL ; ISAM FILE?
POPJ PP, ; NO, RETURN NOW
MOVE AC0,ICHAN(I12) ; YES,GET CHANNEL FOR INDEX FILE
; JRST CHKPNT ; DO IT AND RETURN
; CHKPNT ROUTINE TO DO CHECKPOINT FILOP.
;
; ARG AC0 CONTAINS CHANNEL NUMBER
;
; RETURNS +1 ALWAYS,ERROR IS KILL
; USES AC0
CHKPNT: HRLM AC0,FUSCP. ; PUT CHANNEL IN ARG.BLOCK
MOVE AC0,[1,,FUSCP.] ; POINT AT ARG BLOCK
FILOP. AC0, ; DO FILOP (UPDATE EOF POINTERS)
JRST [OUTSTR [ASCIZ/
?CHECKPOINT FILOP. failed (shouldn't happen)./]
JRST KILL ] ;
POPJ PP, ; OK RETURN
;[523] USER WANTS FILOP. (.FOURB)
;RETURNS
;OK TO CALLER'S CALLER +1
CKFOI:
IFE TOPS20,<
JRST PPOPJ ;RIB UPDATE WILL BE DONE BY MONITOR
>
LDB AC0,F.BCKP ;SEE IF USER WANTS TO CHECKPOINT FILE
JUMPE AC0,PPOPJ ;NO, RETURN TO CALLER'S CALLER+1
MOVE AC0,ICHAN(I12) ;[523] GET CHANNEL FOR INDEX FILE
JRST CKFOC ;[523] DON'T GET CH FOR DATA FILE
CKFOD:
IFE TOPS20,<
JRST PPOPJ ;RIB UPDATE WILL BE DONE BY MONITOR
>
LDB AC0,F.BCKP ;SEE IF USER WANTS TO CHECKPOINT FILE
JUMPE AC0,PPOPJ ;NO, RETURN TO CALLER'S CALLER+1
LDB AC0,DTCN. ;[523] GET CHANNEL FOR DATA FILE
CKFOC: PUSHJ PP,CHKPNT ; DO FILOP.
PPOPJ: POP PP,(PP) ;[523] POP OFF CALLER
POPJ PP, ;[523] GOOD RETURN
;BLOCK NUMBER IS LARGER THAN 18 BITS SO DO A FILOP TYPE USETI
FIUSI: MOVE AC0,ICHAN(I12) ; GET INDEX FILE'S CHANNEL
JRST .+2
FUSI: LDB AC0,DTCN. ; GET DATA FILE'S CHANNEL
HRLM AC0,FUSIA. ; SET IT IN THE ARG-BLOCK
MOVEM AC1,FUSIA.+1 ; SETUP THE BLOCK-NUMBER
MOVE AC0,[2,,FUSIA.] ; POINT AT ARG-BLOCK
FILOP. AC0, ; DO THE USETI
JRST .+1 ; ERROR RETURN
POPJ PP, ; DONE
;BLOCK NUMBER IS LARGER THAN 18 BITS SO DO A FILOP TYPE USETO
FIUSO: MOVE AC0,ICHAN(I12) ; GET INDEX FILE'S CHANNEL
JRST .+2
FUSO: LDB AC0,DTCN. ; GET DATA FILE'S CHANNEL
HRLM AC0,FUSOA. ; SET IT IN THE ARG-BLOCK
MOVEM AC1,FUSOA.+1 ; SETUP THE BLOCK-NUMBER
MOVE AC0,[2,,FUSOA.] ; POINT AT ARG-BLOCK
FILOP. AC0, ; DO THE USETO
JRST .+1 ; ERROR RETURN
POPJ PP, ; DONE
SUBTTL ERROR RECOVERY
;REVERSE EXIT PROCEDURE FOR IGMD
IGMDR: PUSHJ PP,IGMD ;MAKE ERROR NUMBER AND TEST
AOS (PP) ;SKIP EXIT TO FATAL MESSAGE
POPJ PP, ;RETURN
;REVERSE EXIT PROCEDURE FOR IGMI
IGMIR: PUSHJ PP,IGMI ;MAKE ERROR NUMBER AND TEST
AOS (PP) ;SKIP EXIT TO FATAL MESSAGE
POPJ PP, ;RETURN
;INCLUDE MONITOR ERROR STATUS IN AC0
IGMI4: POP PP,-1(PP) ;POP OFF A RETURN
IGMI3: POP PP,-1(PP) ;POP OFF A RETURN
IGMI2: POP PP,-1(PP) ;POP OFF A RETURN
IGMI1: POP PP,-1(PP) ;POP OFF A RETURN
IGMI: PUSHJ PP,SAVAC. ;SAVE ACS
XCT IGETS ;GET THE INDEX FILE ERROR STATUS BITS
SETOM FS.IF ;SET IDX-FILE FLAG
JRST IGMD1 ;
IGMD: PUSHJ PP,SAVAC. ;SAVE ACS
XCT UGETS. ;GET DATA FILE STATUS BITS
SETZM FS.IF ;IDA FILE
IGMD1: TLNE FLG,IDXFIL ;SKIP IF NOT ISAM FILE
MOVEM AC1,FS.BN ;SAVE THE CURRENT BLOCK NUMBER
SETZ AC1, ;INIT AC1 TO ZERO
TXC AC2,IO.ERR ;
TXCN AC2,IO.ERR ;MTA LABEL PROCESSING ERROR?
JRST IGMD2 ;YES
TXNE AC2,IO.IMP ;IMPROPER MODE?
MOVEI AC1,EU%18
TXNE AC2,IO.DER ;DEVICE ERROR
MOVEI AC1,EU%19
TXNE AC2,IO.DTE ;DATA ERROR
MOVEI AC1,EU%20
TXNE AC2,IO.BKT ;QUOTA EXCEEDED, FILE STR, OR RIB FULL
MOVEI AC1,EU%21
TXNE AC2,IO.EOF ;EOF
MOVEI AC1,EU%22
MOVEI AC3,FS%34 ;ASSUME DSK FULL
TXNE AC2,IO.BKT ;IS IT?
JRST IGMD2 ;YES
SKIPN AC3,FS.FS ;NO CHANGE IF NON ZERO
MOVEI AC3,FS%30 ;PERMANENT ERROR
IGMD2: ADD AC0,AC1 ;UPDATE THE ERROR NUMBER
MOVEM AC3,FS.FS ;LOAD FILE-STATUS
JRST IGCV2 ;AVOID CLEARING FS.BN
;REVERSE THE EXIT PROCEDURE FOR IGCV
;POPJ TO IGNORE THE ERROR
;SKIP EXIT TO GET A FATAL MESSAGE
IGCVR2: POP PP,-1(PP) ;POP OFF A RETURN
IGCVR1: POP PP,-1(PP) ;POP OFF ANOTHER
IGCVR: PUSHJ PP,IGCV ;FLAG THE VERB AND TEST FOR IGNORE...
AOS (PP) ;NO -- SKIP EXIT TO FATAL MESS
POPJ PP, ;YES - EXIT
;FLAG THE COBOL VERB
IGCV: PUSHJ PP,SAVAC. ;SAVE ACS
IGCV2: PUSHJ PP,SETSTS ; SET STATUS FIELDS
JRST IGTST ; CHECK FOR IGNORE ERROR
; HERE TO SET UP ERROR NUMBER AND FILE STATUS WORDS
SETSTS: TXNN AC16,V%OPEN
JRST STSTS3 ; NOT OPEN
TXNE AC16,OPN%EX ; OPEN EXTEND?
ADD AC0,[EXP E.VEXT-E.VOPE] ; YES
ADD AC0,[EXP E.VOPE] ; NO, JUST OPEN
JRST STSTS2 ; CONT
STSTS3: TXNN AC16,CLS%EF!CLS%EV!CLS%BV!CLS%IC ;SOME NON-FATAL CLOSE ERROR?
JRST STSTS4 ; NO, SOME OTHER VERB
ADD AC0,[EXP E.VCLO] ;FLAG FOR CLOSE VERB
JRST STSTS2 ;AND GET OUT OF THIS (MESS)
STSTS4: ;
TXNE AC16,V%WADV!V%WRIT
ADD AC0,[EXP E.VWRI]
TXNE AC16,V%RWRT
ADD AC0,[EXP E.VREW]
TXNE AC16,V%DLT
ADD AC0,[EXP E.VDEL]
TXNN AC16,V%STRT ; START?
JRST STSTS1 ; NO,CONT
ADD AC0,[EXP E.VSTR] ; YES, SET IT
JRST STSTS2 ; AND SKIP READ CHECK (ALSO SET FOR STRT)
STSTS1: TXNE AC16,V%READ
ADD AC0,[EXP E.VREA]
;FALL THROUGH TO SETSTX
;BUT FIRST INCLUDE FILE TYPE IN ERROR STATUS
STSTS2: MOVE AC13,D.DC(I16) ;GET DEV CHARACTERISTICS
TXNN AC13,DV.MTA ;IS IT AN MTA?
JRST IGCVF1 ;NO, SO NO LABEL ERRORS
TXC AC2,IO.ERR ;
TXCE AC2,IO.ERR ; IS THIS A MTA LABEL PROCESSING ERROR?
JRST IGCVF1 ; NO
MOVE AC4,[2,,1] ; LENGTH ,, ADDRESS
MOVEI AC1,.DFRES ; FUNCT - EXTENDED IO ERRORS
MOVE AC2,D.ICD(I16) ; ADDRESS OF
MOVE AC2,(AC2) ; SIXBIT /DEVICE/
DEVOP. AC4, ; GET IO ERRORS
SETZ AC4, ; "ERROR" GETTING ERROR CODE!
ADD AC0,[E.FMTA] ; FLAG IT AS LABEL PROCESSING ERROR
ADDI AC0,(AC4) ; ADD IN THE LTC
JRST IGCVF2 ; SKIP OVER THE REST
IGCVF1: TLNE FLG,SEQFIL ;SEQUENTIAL?
ADD AC0,[E.FSEQ] ;YES
TLNE FLG,RANFIL ;RANDOM?
ADD AC0,[E.FRAN] ;YES
IGCVF2: MOVEM AC0,FS.EN ;SAVE THE ERROR-NUMBER
;AND THEN SETUP SEQ/IO FILE FS.BN AND FS.RN
IGBNRN: TXNE AC16,V%OPEN ;OPEN?
JRST IGSS ;YES
TLNE FLG,IOFIL ;[622] IO-FILE?
TLNN FLG,SEQFIL ;SEQ-FILE?
JRST IGBNR1 ;NOT SEQ-IO FILE.
MOVE AC3,D.IE(I16) ;NUMBER OF INPUTS EXECUTED
IMUL AC3,D.BPL(I16) ;TIMES BUFFERS/BLOCK
SUB AC3,D.BPL(I16) ;MINUS BUFFERS/BLOCK
AOSG AC3 ;PLUS ONE UNLESS ITS NEGATIVE
SETZ AC3, ;WHICH MEANS NONE WERE DONE
MOVEM AC3,FS.BN ;SAVE THE BLOCK-NUMBER
MOVE AC3,D.RP(I16) ;RECORDS PROCESSED SO FAR
ADDI AC3,1 ;BRING IT UP TO DATE
MOVEM AC3,FS.RN ;AND SAVE IT AWAY
JRST IGSS ;
;SETUP SEQUENTIAL FILE BLOCK AND RECORD NUMBERS
IGBNR1: TLNN FLG,SEQFIL ;SEQ FILE?
JRST IGSS ;NO
SKIPN AC3,D.IE(I16) ;GET NUMBER OF INPUTS
MOVE AC3,D.OE(I16) ; OR OUTPUTS EXECUTED.
MOVEM AC3,FS.BN ;AND SAVE IT.
MOVE AC3,D.RP(I16) ;GET THE RECORD NUMBER
ADDI AC3,1 ;UPDATE THE COUNT
MOVEM AC3,FS.RN ;AND SAVE IT.
;HERE TO SETUP THE STATUS WORDS
IGSS: SKIPN AC1,F.WPFS(I16) ;GET FILE-STATUS POINTER
JRST SETSTX ;DONE IF NO POINTER
MOVE AC0,FS.FS ;GET FILE-STATUS
PUSHJ PP,IGCNVT ;MOVE IT TO DATA-ITEM
SKIPN AC1,F.WPEN(I16) ;GET ERROR-NUMBER POINTER
JRST SETSTX ;DONE IF NO POINTER
MOVE AC0,FS.EN ;GET ERROR-NUMBER
PUSHJ PP,IGCNVT ;MOVE IT TO DATA-ITEM
SKIPN AC1,F.WPAC(I16) ;GET ACTION-CODE POINTER
JRST SETSTX ;DONE IF NO POINTER
SETZM (AC1) ;ZERO THE ACTION CODE
MOVE AC2,F.WPID(I16) ;GET VALUE-OF-ID POINTER
JUMPE AC2,SETSTX ;DONE IF NO POINTER
HLRZ I12,D.BL(I16) ;RESTORE I12
HRRI AC1,DFILNM(I12) ;ADR OF IDA-FILE NAME
HRLI AC1,(POINT 6,) ;NOW ITS AN INPUT BYTE-PTR
MOVE FLG,-10(PP) ;RESTORE FLG (EXTRA -1 FOR CALL)
TLNE FLG,IDXFIL ;AN ISAM FILE?
SKIPE FS.IF ;YES - IDX OR IDA?
MOVE AC1,F.WVID(I16) ;GET THE REAL VID POINTER
LDB AC3,[POINT 2,AC1,11] ;GET INPUT BYTE SIZE
LDB AC4,[POINT 2,AC2,11] ;GET DESTINATION BYTE SIZE
TLZ AC2,007700 ;ZERO BYTE FIELD
PUSH PP,I16 ;SAVE I16
MOVEI AC16,1 ;SETUP PARAMETER WORD
PUSHJ PP,@IGTAB2-1(AC3) ;MOVE IT TO DATA-ITEM
POP PP,I16 ;RESTORE AC16
SKIPN AC1,F.WPBN(I16) ;GET BLOCK-NUMBER POINTER
JRST SETSTX ;DONE IF NO POINTER
MOVE AC0,FS.BN ;GET BLOCK-NUMBER
MOVEM AC0,(AC1) ;MOVE IT TO DATA-ITEM
SKIPN AC1,F.WPRN(I16) ;GET RECORD-NUMBER POINTER
JRST SETSTX ;DONE IF NO POINTER
MOVE AC0,FS.RN ;GET RECORD-NUMBER
MOVEM AC0,(AC1) ;MOVE IT TO DATA-ITEM
SKIPN AC2,F.WPFN(I16) ;GET POINTER TO FILE-NAME
JRST SETSTX ;DONE IF NONE
MOVE AC1,I16 ;GET FILE-TBL FILE-NAME POINTER
HRLI AC1,(POINT 6,) ;MAKE IT A BYTE POINTER
LDB AC4,[POINT 2,AC2,11] ;GET BYTE SIZE
TLZ AC2,007700 ;ZERO BYTE FIELD
PUSH PP,I16 ;SAVE I16
MOVEI AC16,1 ;SETUP PARAMETER WORD
PUSHJ PP,@IGTAB4-1(AC4) ;MOVE IT TO DATA-ITEM
POP PP,I16 ;RESTORE I16
HRRZM I16,@F.WPFT(I16) ;SET FILE-TABLE PTR TO DATA-ITEM
SETSTX: POPJ PP, ; ALL DONE, RETURN
;CALL = PUSHJ PP,IG????
;AC0 = THE ERROR NUMBER
;RETURN
;POPJ IF THERE IS NO ERROR USE PROCEDURE
; OR IF THE ACTION CODE POINTER, F.WPAC IS ZERO
; OR IF THE ACTION CODE IS ZERO
; GIVE ERROR MESSAGE AND KILL
;SKIP EXIT IF (F.WPAC) IS NON-ZERO TO IGNORE THE ERROR
IGTST:
MOVE AC1,FS.FS ;GET ERROR CODE
CAIN AC1,FS%10 ;ALL OTHER END-OF-FILE?
JRST IGTST2 ;YES
SKIPGE WANT8. ;WANT 8x FUNCT?
TXNN AC16,V%READ ;DOING READ?
JRST IGTST4 ; NO, NO
MOVX AC1,B%BDRD ;SET BAD-READ FLAG
IORM AC1,D.RFLG(I16) ; AND PUT IT BACK IN FILE TABLE.
IGTST4:
SKIPE FS.IGE ;ANY ERRORS IGNORED YET?
JRST IGTST2 ;YES - IGNORE ALL FOR DURATION OF THIS VERB
MOVE FLG,-7(PP) ;[501] RESTORE FLAG. NOTE ** THIS
;ASSUMES THAT A "PUSHJ SAVAC" HAS
;BEEN DONE PRIOR TO COMING HERE.
MOVEI AC1,0 ;CALL THE ERROR USE PROCEDURE
PUSHJ PP,USEPRO ;DO IT
JRST IGTST1 ;THERE IS ONE
JRST RSTAC1 ;THERE IS NONE
IGTST1: SETOM FS.UPD ;REMEMBER ERROR USE-SRO WAS DONE
SKIPE AC1,F.WPAC(I16) ;IS THERE AN F.WPAC POINTER?
SKIPN AC1,(AC1) ;YES, IGNORE THE ERROR?
JRST RSTAC1 ;NO -- MESSAGE AND KILL
SETOM FS.IGE ;YES -- FOR THE DURATION OF THIS VERB
AOS FS.IEC ; COUNT IGNORED ERRORS
IGTST2: PUSHJ PP,RSTAC. ;RESTORE ACS
JRST RET.2 ;SKIP EXIT
;HERE TO MOVE DECIMAL NUMBER TO DISPLAY FIELD
;AC0 HAS THE NUMBER
INTERN IGCNVT ;CALLED BY LBLERR
IGCNVT: PUSH PP,I16 ;SAVE THE FILE-TABLE POINTER
LDB AC3,[POINT 2,AC1,11] ;PICKUP THE BYTE SIZE
TLZ AC1,007700 ;ZERO THE SIZE FIELD
MOVEI AC16,1 ;SETUP PARAMETER WORD
PUSHJ PP,@IGTAB1-1(AC3) ;CONVERT AND MOVE IT
POP PP,I16 ;RESTORE I16
POPJ PP, ;RETURN
IGTAB1: PD9. ;DECIMAL TO EBCDIC
PD6. ;DECIMAL TO SIXBIT
PD7. ;DECIMAL TO ASCII
IGTAB2:: @ IGTAB3-1(AC4) ;EBCDIC TO SOMETHING
@ IGTAB4-1(AC4) ;SIXBIT TO SOMETHING
@ IGTAB5-1(AC4) ;ASCII TO SOMETHING
IGTAB3: MOVE. ;EBCDIC TO EBCDIB
C.D9D6 ;EBCDIC TO SIXBIT
C.D9D7 ;EBCDIC TO ASCII
IGTAB4:: C.D6D9 ;SIXBIT TO EBCDIC
MOVE. ;SIXBIT TO SIXBIT
C.D6D7 ;SIXBIT TO ASCII
IGTAB5: C.D7D9 ;ASCII TO EBCDIC
C.D7D6 ;ASCII TO SIXBIT
MOVE. ;ASCII TO ASCII
SUBTTL FILE STATUS
; ROUTINE TO SET UP FILE STATUS WORDS
STSTAT: PUSHJ PP,SAVAC. ; SAVE THE AC'S
SETZ AC0, ; CLEAR ERROR NUMBER ARG
PUSHJ PP,SETSTS ; SET UP WORDS
JRST RSTAC1 ; RESTORE AC'S AND POPJ
;SET FILE STATUS WORD (IF IT EXISTS) TO 00
CLRSTS: SKIPE AC1,F.WPFS(I16) ;FILE STATUS WORD?
SKIPE FS.FS ;YES AND OK STATUS?
POPJ PP, ;NO, ASSUME ITS ALREADY SET UP
PUSHJ PP,STSTAT ; SET REST OF STATUS FIELDS
MOVE AC1,F.WPFS(I16) ;GET FILE STATUS PTR
LDB AC2,[POINT 2,AC1,11] ;GET BYTE SIZE TO FIND TYPE
MOVE AC2,[EXP 360,'0',"0"]-1(AC2) ;GET ZERO
CLRST2: TLZ AC1,77 ;CLEAR COUNT
IDPB AC2,AC1 ;STORE STATUS
CLRST1: IDPB AC2,AC1 ;BOTH CHARACTERS
POPJ PP,
;SET FILE STATUS WORD (IF IT EXISTS) TO 10
SETS10: MOVEI AC0,FS%10 ; [601] READ INVALID KEY
SET10A: ;
MOVEM AC0,FS.FS ; [601] LOAD FILE-STATUS
SKIPN AC1,F.WPFS(I16) ;FILE STATUS WORD?
POPJ PP, ;NO
PUSHJ PP,STSTAT ; SET REST OF STATUS FIELDS
MOVE AC1,F.WPFS(I16) ;GET FILE STATUS PTR
LDB AC2,[POINT 2,AC1,11] ;GET BYTE SIZE TO FIND TYPE
MOVE AC2,[EXP 361,'1',"1"]-1(AC2) ;GET TEN
TLZ AC1,77 ;CLEAR COUNT
IDPB AC2,AC1 ;STORE STATUS
SOJA AC2,CLRST1 ;STORE ZERO
;SET FILE STATUS WORD (IF IT EXISTS) TO 22
SETS22: HLLZS UIN. ;[666] RESET UIN.
SKIPN AC1,F.WPFS(I16) ;[666] FILE STATUS WORD?
POPJ PP, ;NO
PUSHJ PP,STSTAT ; SET REST OF STATUS FIELDS
MOVE AC1,F.WPFS(I16) ;GET FILE STATUS PTR
LDB AC2,[POINT 2,AC1,11] ;GET BYTE SIZE TO FIND TYPE
MOVE AC2,[EXP 362,'2',"2"]-1(AC2) ;GET TEN
JRST CLRST2 ;STORE BOTH CHATACTERS
;SET FILE STATUS WORD (IF IT EXISTS) TO 23
SETS23: MOVEI AC0,FS%23 ;[601] GET FS.FS NUMBER FOR REC NOT FOUND
MOVEM AC0,FS.FS ;[601] SET IT
SKIPN AC1,F.WPFS(I16) ;FILE STATUS WORD?
POPJ PP, ;NO
PUSHJ PP,STSTAT ; SET REST OF STATUS FIELDS
MOVE AC1,F.WPFS(I16) ;GET FILE STATUS PTR
LDB AC2,[POINT 2,AC1,11] ;GET BYTE SIZE TO FIND TYPE
MOVE AC2,[EXP 362,'2',"2"]-1(AC2) ;GET TEN
TLZ AC1,77 ;CLEAR COUNT
IDPB AC2,AC1 ;STORE STATUS
CLRST3: AOJA AC2,CLRST1 ;STORE "3"
;SET FILE STATUS WORD (IF IT EXISTS) TO 24
SETS24: SKIPN AC1,F.WPFS(I16) ;FILE STATUS WORD?
POPJ PP, ;NO
PUSHJ PP,STSTAT ; SET REST OF STATUS FIELDS
MOVE AC1,F.WPFS(I16) ;GET FILE STATUS PTR
LDB AC2,[POINT 2,AC1,11] ;GET BYTE SIZE TO FIND TYPE
MOVE AC2,[EXP 362,'2',"2"]-1(AC2) ;GET TEN
TLZ AC1,77 ;CLEAR COUNT
IDPB AC2,AC1 ;STORE STATUS
AOJA AC2,CLRST3 ;STORE "4"
SUBTTL RERUN-DUMP-CODE
;SCAN FOR AN OPEN RANDOM IO FILE
RRDMP: PUSHJ PP,SAVAC. ;SAVE AC'S
MOVE AC15,REDMP. ;SAVE THE "FORCE-DUMP" FLAG
SETZB AC0,REDMP. ;CLEAR THE "FORCE-DUMP" FLAG
SKIPN AC1,RRFLG. ; FLG IS SET IF RERUN CLAUSE WAS USED
SKIPN OPNCH. ; ANY CHANNELS AVAILABLE?
JUMPE AC1,RRERR5 ; IF NOT - ERROR
IFN DBMS,<
SKIPE DBMLOK## ;[520] IS THIS A DBMS PROGRAM?
JRST RRDM10 ;[520] YES, ERROR
>;END IFN DBMS
SKIPN KEYCV. ; [431] ARE WE SORTING?
JRST RRDMP7 ; [431] NO
PUSHJ PP,RRERR0 ; [431] COMPLAIN
OUTSTR [ASCIZ / SORT in progress.
/]
JRST RRXIT ; [431] THEN EXIT.
RRDMP7: SKIPN OVRFN. ;IF OVERLAY FILE IS OPEN
JRST RRDMP6 ;
PUSHJ PP,RRERR0 ; ABORT -- CHANNEL 1 IS IN USE
OUTSTR [ASCIZ/ OVERLAY/]
JRST RRDMP9 ;
RRDMP6: SYSPHY AC0, ;SYSPHY UUO ;XIT IF LEVEL C
JRST RSTAC1 ;EXIT
HRRZ AC16,FILES. ;POINT TO FIRST FILE TABLE
TRNA
RRDMP1: HRRZ AC16,F.RNFT(I16);POINTER TO NEXT FILE-TABLE
JUMPN AC16,RRDMP5 ;
;SCAN FOR OPEN OUTPUT FILES
RRDMP2: PUSH PP,.JBFF ; SAVE START OF LOWSEG FREE SPACE
HRRZ AC16,FILES. ;FIRST FILE-TABLE
TRNA
RRDMP3: HRRZ AC16,F.RNFT(I16);NEXT FILE-TABLE
JUMPE AC16,RRDIT ;GO DUMP IT
MOVE FLG,F.WFLG(I16) ;FLAGS
TLNN FLG,OPNIN!OPNOUT ;SKIP IF FILE IS OPEN
JRST RRDMP4 ;ELSE CONT
MOVE AC1,F.WDNM(I16) ;DEVICE POINTER
MOVE AC1,(AC1) ;6BIT DEVICE NAME
MOVEM AC1,D.RD(I16) ;SAVE IT FOR RERUN
RRDMP4: TLNE FLG,IDXFIL ; ISAM FILE??
JRST RRDMPI ; YES, GO DO IT
TLNN FLG,OPNOUT ;SKIP IF OPEN FOR OUTPUT
JRST RRDMP3 ;LOOP
MOVE AC13,D.DC(I16) ;DEVCHR
TXC AC13,DV.DSK!DV.CDR ;[321];IF IT'S A DSK AND A CARD READER
TXCE AC13,DV.DSK!DV.CDR ;[321]; IT'S THE NULL DEVICE - SO SKIP
TXNN AC13,DV.DSK!DV.MTA ;SKIP IF DSK OR MTA
JRST RRDMP3 ;
PUSHJ PP,SETCN. ;SET CHAN NUMBER
TLNN FLG,IOFIL!RANFIL ;[622] SKIP IF DSK DUMP MODE
JRST RRBUF ;DSK/MTA BUFFERED MODE
;DSK DUMP MODE
PUSHJ PP,RRCLE ;CLOSE, LOOKUP, ENTER SEQUENCE
MOVE AC1,D.CBN(I16) ;NEXT BLOCK
PUSHJ PP,FUSI ; DO A FILOP. TYPE USETI
JRST RRDMP3 ;CONT LOOP
RRDMP5: MOVE AC13,D.DC(I16) ;DEVCHR TO 13
MOVE FLG,F.WFLG(I16) ;FLAGS TO FLG
TLNN FLG,OPNIN!OPNOUT
JRST RRDMP1 ;THIS FILE IS NOT OPEN = CONT
TXC AC13,DV.DSK!DV.CDR ;[321];
TXCN AC13,DV.DSK!DV.CDR ;[321];NULL DEVICE
JRST RRDMP1 ;[321];YES -- GO ON
SKIPE F.WSMU(I16) ; ENQ'ING?
JRST [PUSHJ PP,RRERR0 ; "DUMP ABORTED"
OUTSTR [ASCIZ/ SIMULTANEOUS UPDATE/]
JRST RRDMP9] ; "FILE IS OPEN"
TXNN AC13,DV.CDR!DV.PTP!DV.PTR!DV.DTA ;(REMOVED LPT:) 7/25/78
JRST RRDMP1 ;NO, CONT SCAN
RRDMP8: PUSHJ PP,RRERR0 ;DUMP ABORTED
TXNE AC13,DV.CDR ;CARDS?
OUTSTR [ASCIZ / CARD/]
TXNE AC13,DV.PTP!DV.PTR ;PAPER TAPE?
OUTSTR [ASCIZ / PAPER-TAPE/]
IFE TOPS20,<
TXNE AC13,DV.DTA ;
OUTSTR [ASCIZ / DEC-TAPE/]
>
RRDMP9: OUTSTR [ASCIZ / file is OPEN.
/]
JRST RRXIT ;EXIT NO DUMP
RRDM10: PUSHJ PP,RRERR0 ;[520] YES WE CAN'T RERUN SO DON'T DUMP
OUTSTR [ASCIZ / Program has calls to DBMS.
/]
JRST RRXIT ;[520] THEN EXIT
;CLOSE LOOKUP ENTER ROUTINE
RRCLE: XCT UCLOS. ;CLOSE, ENSURES FILES CURRENT STATE IS PRESERVED
PUSHJ PP,WRTWAI ;CHECK FOR ERRORS
RRCLE1: PUSHJ PP,OPNLID ;SET UP LOOKUP BLOCK
XCT ULKUP. ;LOOKUP
JRST LOOKER ;ERROR
IFE TOPS20,<
TXNE AC13,DV.DTA ;SKIP IF NOT DTA
POPJ PP, ;
>
RRCLE2: PUSHJ PP,OPNEID ;ENTER BLK
XCT UENTR. ;ENTER
JRST ENTRER ;ERROR
POPJ PP, ;
RRDMPI:
; FIRST SAVE IDX AND IDA DEVICE NAMES IF TOPS10
IFE TOPS20,<
MOVE AC2,.JBFF ; GET FREE CORE POINTER
MOVEI AC3,2 ; INDICATE NEED TWO WORDS FOR TWO DEVICE NAMES
ADDB AC3,.JBFF ; INCREMENT FREE CORE POINTER
CAMGE AC3,.JBREL ; SKIP IF NEED MORE CORE
JRST RRDMI1 ; ELSE CONT
CORE AC3, ; EXPAND CORE
JRST RRERR4 ; ERROR, CAN'T DO IT
RRDMI1: HRRZ AC3,F.WDNM(I16) ; GET ADDR OF IDX DEVICE NAME
DMOVE AC0,(AC3) ; GET IDX AND IDA DEVICE NAMES
DMOVEM AC0,(AC2) ; SAVE THEM IN FREE CORE
MOVEM AC2,D.RD(I16) ; SAVE ADDR TO IDX AND IDA DEVICE NAMES
>
; IF NOT OPEN FOR OUTPUT, DON'T BOTHER TO CLOSE AND REOPEN
; JUST CONTINUE OPEN FILE SEARCH. THIS IS REALLY ONLY FOR
; TOPS10, WHICH MUST SAVE IDX AND IDA DEVICE NAMES FOR
; FILES OPEN FOR INPUT
TLNN FLG,OPNOUT ;SKIP IF OPEN FOR OUTPUT
JRST RRDMP3 ;LOOP
HLRZ AC12,D.BL(I16) ; GET BUFFER LOCATION
MOVE AC5,ICHAN(I12) ; GET IDX CHANNEL NUMBER
PUSHJ PP,SETC1. ; GO SET UP FOR IDX UUO'S
XCT UCLOS. ;CLOSE, ENSURES FILES CURRENT STATE IS PRESERVED
PUSHJ PP,WRTWAI ;CHECK FOR ERRORS
PUSHJ PP,OPNLIX ;SET UP LOOKUP BLOCK
RRDMIL: XCT ULKUP. ;LOOKUP
JRST LOKERI ;ERROR
RRDMIE: PUSHJ PP,OPNEIX ;ENTER BLK
XCT UENTR. ;ENTER
JRST ETRERI ;ERROR
; NOW SET UP TO SAVE IDA FILE
PUSHJ PP,SETCN. ; SPREAD IDA CHANNEL NUM AROUND
PUSHJ PP,RRCLE ; NOW CLOSE,LOOKUP,ENTER IDA FILE
JRST RRDMP3 ; AND CONTINUE WITH NEXT FILE IN FILTAB
LOOKER: PUSHJ PP,LUPERR ;ERROR MESSAGE
JRST RRCLE1 ;TRY AGAIN
ENTRER: PUSHJ PP,ENRERR ;
JRST RRCLE2 ;
LOKERI: PUSHJ PP,LUPERR ;ERROR MESSAGE
JRST RRDMIL ;TRY AGAIN
ETRERI: PUSHJ PP,ENRERR ; ERROR MESSAGE
JRST RRDMIE ; TRY AGAIN
;BUFFERED MODE
RRBUF: PUSH PP,D.OBC(I16) ;OUTPUT
PUSH PP,D.OBB(I16) ;BUFFER
PUSH PP,D.OBH(I16) ;HEADER
HRR AC1,D.OBH(I16) ;CURRENT BUFFER'S ADR
ADDI AC1,1 ;MAKE BYTPTR INDICATE EMPTY BUFFER
HRRM AC1,D.OBB(I16) ;HDR BYTE-POINTER
PUSHJ PP,RRCLE ;CLOSE, LOOKUP, ENTER
TXNE AC13,DV.MTA ;MTA?
JRST RRBUF5 ;YES
POP PP,D.OBH(I16) ;OUTPUT
POP PP,D.OBB(I16) ;BUFFER
POP PP,D.OBC(I16) ;HEADER
MOVE AC1,D.OE(I16) ;NUMBER OF OUTPUTS
AOJA AC1,RRBUF2 ;DSK
RRBUF2: PUSHJ PP,FUSO ; DO A FILOP. TYPE USETO
JRST RRDMP3 ;
;MAG-TAPE, IF CLOSE GENERATED AN EOF BACK OVER IT
RRBUF5: XCT UOUT. ;DUMMY OUTPUT, ??? IT WORKS
XCT MBSPR. ;BACKUP ONE RECORD (EOF)
IFE TOPS20,<
XCT MWAIT. ;WAIT FOR TAPE MOTION TO STOP
>
XCT UGETS. ;GET STATUS INTO AC2
TXNN AC2,IO.EOF!IO.BOT ;SKIP IF EOF OR BOT
XCT MADVR. ;NOT AN EOF, SPACE OVER IT
;NOW MOVE WHAT WAS THE CURRENT BUFFER TO THE CURRENT CURRENT BUFFER
HRR AC2,D.OBH(I16) ;TO - 1
HRL AC2,(PP) ;FROM - 1
HLRZ AC1,(AC2) ;BUF SIZE, MAY CHANGE FROM FILE TO FILE
ADDI AC1,(AC2) ;UNTIL
AOBJP AC2,.+1 ;FROM,,TO
BLT AC2,(AC1) ;MOVIT
;UPDATE THE HEADER
POP PP,AC1 ;FRST HDR WRD
POP PP,AC2 ;BYTE-PTX
SUBI AC2,(AC1) ;#OF WRDS IN BFR
HRRZ AC1,D.OBH(I16) ;CRNT BFRS ADR
ADD AC2,AC1 ;NEW BYTE-PTR
MOVEM AC2,D.OBB(I16) ;SAVIT
POP PP,D.OBC(I16) ;OLD BYTE-CNT
JRST RRDMP3 ;NEXT
RC==1 ;RERUN IO CHANNEL
;DUMP THE LOWSEG
RRDIT: MOVEI AC5,RC ; GET DEFAULT CHANNEL
SKIPN RRFLG. ; USE IT IF RERUN CLAUSE WAS USED
PUSHJ PP,GCHAN ; ELSE GET ON FROM THE POOL
MOVEI AC3,'DSK'
HRLZM AC3,UOBLK.+1 ;DEVICE NAME
MOVEI AC3,.IODMP ;DUMP MODE
HRRZM AC3,UOBLK. ;
SETZM UOBLK.+2 ;ELSE LAST BUF-HDR IS OVER-WRITTEN
MOVE AC6,[OPEN UOBLK.]
DPB AC5,[POINT 4,AC6,12]
XCT AC6
JRST RRERR ;ERROR
HRROI AC3,.GTPRG ;USER PROGRAN NAME
GETTAB AC3, ;PROGRAM NAME TO AC3
JRST RRERR3 ;ERROR RET ;HRLZI AC3,(SIXBIT /PKC/)
MOVEM AC3,UEBLK. ;LOW-SEG NAME
HRLZI AC3,'CKP'
HLLZM AC3,UEBLK.+1 ;EXTENSION
SETZM UEBLK.+2
SETZM UEBLK.+3
MOVE AC6,[ENTER UEBLK.]
DPB AC5,[POINT 4,AC6,12]
XCT AC6
JRST RRERR1 ;ERROR
MOVS AC1,HLOVL. ; IF THERE IS AN OVERLAY AREA GET
ADDI AC1,1 ; ADR OF FIRST FREE LOC FOLLOWING IT
CAIE AC1,1 ; SKIP IF NO LINK TYPE OVERLAY
HRRZM AC1,.JBFF ; USE THIS AREA FOR JOBDATA STORAGE
HRRZ AC0,.JBFF ;
ADDI AC0,.JBDA ;
CAMGE AC0,.JBREL ;SKIP IF NEXT BLT VIOLATES MEMORY
JRST RRDIT3 ;
CORE AC0, ;EXPAND CORE
JRST RRERR4 ;ERROR RET
RRDIT3: MOVE AC0,FILES. ;
HRL AC0,.JBFF ;FRST FREE
MOVEM AC0,TEMP. ;FIRST FILE TABLE
MOVEM PP,TEMP.1 ;PP POINTER
HRLI AC10,TEMP. ;POINTER TO FILES. AND PP
HRR AC10,.JBREL ;LENGTH FOR IOWD
HRRZ AC1,.JBFF ;
MOVEM AC10,(AC1) ;INTO FIRST FREE LOC
HRROI AC1,-1(AC1) ;IOWD
PUSH PP,2(AC1)
MOVE AC2,LIBVR. ;STORE VERSION #
MOVEM AC2,2(AC1) ;SO WE KNOW ITS V12 OR LATER
IFN TOPS20,<
HRRZ AC2,JSARR. ;GET POINTER TO START.
MOVE AC3,(AC2) ;GET JSP
CAMN AC3,[JFCL]
MOVE AC3,1(AC2) ;GET JSP!
MOVE AC2,2(AC3) ;GET POINTER TO JFN STRING
PUSH PP,3(AC1) ;JUST IN CASE
MOVEM AC2,3(AC1) ;STORE IT
HRLI AC1,-3 ;WRITE OUT 3 WORDS
>
IFE TOPS20,<
HRLI AC1,-2 ;WRITE OUT 2 WORDS
>
SETZ AC2, ;TERMINATOR
MOVE AC6,[OUT AC1] ;FIRST RECORD ;TEMP.,,(.JBREL)
DPB AC5,[POINT 4,AC6,12]
XCT AC6
TRNA
JRST RRERR2 ;OUTPUT ERROR
IFN TOPS20,<
POP PP,3(AC1) ;RESTORE
>
POP PP,2(AC1) ;RESTORE
HRRZ AC1,.JBFF ;SAVE JOBDATA AREA
MOVEI AC3,.JBDA(AC1) ;UNTIL
BLT AC1,(AC3) ; STARTING AT .JBFF
MOVNI AC1,-140(AC10) ;IOWD FOR SECOND RECORD
HRL AC1,AC1 ;ALL OF LOW-SEG
HRRI AC1,.JBDA-1 ; BUT JOB-DATA AREA
MOVE AC6,[OUT AC1] ;SECOND RECORD
DPB AC5,[POINT 4,AC6,12]
XCT AC6
TRNA
JRST RRERR2 ;OUTPUT ERROR
POP PP,.JBFF ; RESTORE THE STACK AND JOBFF
MOVSI AC6,(CLOSE)
DPB AC5,[POINT 4,AC6,12]
XCT AC6
OUTSTR [ASCIZ /DUMP completed.
/]
RRXIT: AOSN AC15 ;SKIP IF NOT FORCED
EXIT 1, ;EXIT IF IT WAS FORCED
JRST RSTAC1 ;RESTORE ACS AND POPJ
RRERR0: OUTSTR [ASCIZ /DUMP aborted ./]
POPJ PP, ;
;OPEN FAILED
RRERR: PUSHJ PP,RRERR0 ;
OUTSTR [ASCIZ /OPEN failed. /]
JRST RRXIT ;
;ENTER FAILED
RRERR1: PUSHJ PP,RRERR0 ;
OUTSTR [ASCIZ /ENTER failed,/]
HRRZ AC2,UEBLK.+1 ;THE ERROR BITS
TRZ AC2,777740 ; NOTHING ELSE
CAIL AC2,LEMLEN ;LEGAL MESSAGE?
HRRI AC2,LEMLEN ;NO
CAIN AC2,0 ;
HRRI AC2,LEMLEN+1 ;ILL-FIL-MAME
OUTSTR @LEMESS(AC2) ;COMPLAIN
JRST RRERRX ;ERROR EXIT
;OUTPUT FAILED
RRERR2: POP PP,.JBFF ; RESTORE THE STACK AND JOBFF
PUSHJ PP,RRERR0 ;
OUTSTR [ASCIZ /OUTPUT error, /]
GETSTS RC,AC2 ;ERROR STATUS
PUSHJ PP,IOERM1 ;COMPLAIN
RRERRX: OUTSTR [ASCIZ /
/]
CLOSE RC,CL.RST ;CLOSE, BUT DONT SUPERCEDE
JRST RSTAC1 ;EXIT
;CAINT FIND THE PROGRAM NAME
RRERR3: PUSHJ PP,RRERR0 ;
OUTSTR [ASCIZ /Cannot find program name./]
JRST RRERRX ;
;CORE UUO FAILED
RRERR4: POP PP,.JBFF ; RESTORE THE STACK AND JOBFF
PUSHJ PP,RRERR0
OUTSTR [ASCIZ /CORE UUO failed./]
JRST RRERRX ;
;NO IO CHANNELS FOR THE DUMP FILE
RRERR5: PUSHJ PP,RRERR0
OUTSTR [ASCIZ /No channels available./]
JRST RRERRX
SUBTTL POINTERS AND THINGS
FLPS10: POINT 6,F.WPMT(AC10),17 ;FILE POSITION USING AC10
WOPRS.: POINT 12,AC15,11 ;RECORD SIZE IN CHARS
WOPCN: POINT 3,AC15,17 ;LPT CHANNEL NUMBER
STDLBP: POINT 6,STDLB. ;STANDARD LABEL POINTER
OPNCBP:: POINT 1,OPNCH.,0 ;[342]POINTER TO CHAN. STATUS
IFN SIRUS<SIRDEV: SIXBIT/SIRS/ ; SIRUS ARCHIVE DEVICE >
;CONSTANTS FOR ISAM
KY.TP: POINT 18,1+KEYDES(AC1),17 ; KEY TYPE
KY.MD: POINT 2,1+KEYDES(AC1),19 ; MODE OF FILE
KY.TYP: POINT 18,KEYDES(I12),17 ; KEY TYPE
KY.MOD: POINT 2,KEYDES(I12),19 ; MODE OF FILE
KY.SGN: POINT 1,KEYDES(I12),20 ; ONE IF UNSIGNED
;NOTE: UNTIL V11, THIS WAS INCORRECTLY
;DOCUMENTED AS 'ONE IF SIGNED'
;REVERSING THE EFFECTS FOR COMP-3
;EBCDIC LOW-VALUE RECORD KEYS.
KY.SIZ: POINT 12,KEYDES(I12),35 ; KEY SIZE
UUOCHN: POINT 4,UOPEN.,12 ; CHANNEL NUMBER AS SET IN OPEN UUO XCT WORD
DTCN.: F%BCN ; CHANNEL NUMBER
DTIBS.: F%BIBS ; INPUT HEADER BYTE SIZE
DTOBS.: F%BOBS ; OUTPUT HEADER BYTE SIZE
DTRN.: F%BRN ; MTA REEL NUMBER
F.NIO: F%NIO ; NATIVE I/O BIT
F.BLF:: F%BLF ; LOCK FLAG
F.BNDV: F%BNOD ; NUMBER OF DEVICES SELECTED
F.BCVR: F%BCVR ; COMPILER'S VERSION NUMBER
F.BBLC:: F%BBLC ; BUFFER LOCATION IS ASSIGNED
F.BSDF: F%BSDF ; SORT-DESCRIPTION FILE FLAG
F.BDRM: F%BDRM ; OPEN REVERSED ACTIVE FLAG
F.BNOD: F%BNOD ; NUMBER OF DEVICES ASSIGNED TO FILE
F.BFAM: F%BFAM ; FILE ACCESS MODE
F.BLBT: F%BLBT ; SYSTEM LABEL TYPE (SEE MONITOR CALLS FOR CODE VALUES)
F.BLBU: F%BLBU ; "U" FORMAT SYSTEM LABEL FORMAT FLAG BIT
F.BLBF: F%BLBF ; "F" FORMAT SYSTEM LABEL FORMAT FLAG BIT
F.BLBD: F%BLBD ; "D" FORMAT SYSTEM LABEL FORMAT FLAG BIT
F.BLBS: F%BLBS ; "S" FORMAT SYSTEM LABEL FORMAT FLAG BIT
F.BFMT: F%BFMT ; LABELED TAPE FORMAT BITS
F.BPMT: F%BPMT ; FILE POSITION ON MAG-TAPE
F.BNAB: F%BNAB ; NUMBER OF ACTUAL BUFFERS
F.BRMS:: F%BRMS ; THE RMS FILE FLAG
F.BMRS:: F%BMRS ; MAXIMUM RECORD SIZE IN CHARS
F.BLRS:: F%BLRS ; MINIMUM RECORD SIZE IN CHARS
F.BBKF: F%BBKF ; THE BLOCKING FACTOR
F.BPAR: F%BPAR ; MAG-TAPE PARITY
F.BDNS: F%BDNS ; MAG-TAPE DENSITY
F.BDIO: F%BDIO ; DEFERRED ISAM OUTPUT FLAG
F.BOUP: F%BOUP ; OPEN USE-PROCEDURE WHEN ENTER FAILS
F.BBM: F%BBM ; BYTE MODE FLAG
F.BCKP: F%BCKP ; CHECKPOINT ISAM FLAG
F.BCRC: F%BCRC ; CHECKPOINT ON RECORD COUNT
F.QOPN: F%BQOF ; [565] LFENQ. OPEN FLAG
;[565] 0= NOT AFTER LFENQ. OPEN
;[565] 1= AFTER LFENQ. OPEN
F.BSID: F%BSID ; SIZE OF VALUE OF ID
;THE TABLE IS USED TO CONVERT FROM LOWER CASE TO UPPER CASE
;TO SIXBIT ETC. END-OF-LINE (EOL) CHARS ARE NEGATIVE.
; SIXBIT ASCII ;CHAR
CHTAB: XWD 0, 0 ;
XWD 0, 1 ;
XWD 0, 2 ;
XWD 0, 3 ;
XWD 0, 4 ;
XWD 0, 5 ;
XWD 0, 6 ;
XWD 0, 7 ;
XWD 0, 10 ;
XWD 0, 11 ;HT
XWD 400000, 400012 ;LF
XWD 400000, 400013 ;VT
XWD 400000, 400014 ;FF
IFE SIRUS,<XWD 400000, 400015 ;CR >
IFN SIRUS,<XWD 0, 0 ;CR TREAT AS NULL-IE. IGNORE >
XWD 0, 16 ;
XWD 0, 17 ;
XWD 400000, 400020 ;DLE
XWD 400000, 400021 ;DC1
XWD 400000, 400022 ;DC2
XWD 400000, 400023 ;DC3
XWD 400000, 400024 ;DC4
XWD 0, 25 ;
XWD 0, 26 ;
XWD 0, 27 ;
XWD 0, 30 ;
XWD 0, 31 ;
XWD 400000, 400032 ;TTY EOF (^Z)
XWD 0, 33 ;ALT-MODE
XWD 0, 34 ;
XWD 0, 35 ;
XWD 0, 36 ;
XWD 0, 37 ;
XWD 0, 40 ;SPACE
XWD 1, 41 ;!
XWD 2, 42 ;"
XWD 3, 43 ;#
XWD 4, 44 ;$
XWD 5, 45 ;%
XWD 6, 46 ;&
XWD 7, 47 ;'
XWD 10, 50 ;(
XWD 11, 51 ;)
XWD 12, 52 ;*
XWD 13, 53 ;+
XWD 14, 54 ;,
XWD 15, 55 ;-
XWD 16, 56 ;.
XWD 17, 57 ;/
XWD 20, 60 ;0
XWD 21, 61 ;1
XWD 22, 62 ;2
XWD 23, 63 ;3
XWD 24, 64 ;4
XWD 25, 65 ;5
XWD 26, 66 ;6
XWD 27, 67 ;7
XWD 30, 70 ;8
XWD 31, 71 ;9
XWD 32, 72 ;:
XWD 33, 73 ;;
XWD 34, 74 ;<
XWD 35, 75 ;=
XWD 36, 76 ;>
XWD 37, 77 ;?
XWD 40, 100 ;@
XWD 41, 101 ;A
XWD 42, 102 ;B
XWD 43, 103 ;C
XWD 44, 104 ;D
XWD 45, 105 ;E
XWD 46, 106 ;F
XWD 47, 107 ;G
XWD 50, 110 ;H
XWD 51, 111 ;I
XWD 52, 112 ;J
XWD 53, 113 ;K
XWD 54, 114 ;L
XWD 55, 115 ;M
XWD 56, 116 ;N
XWD 57, 117 ;O
XWD 60, 120 ;P
XWD 61, 121 ;Q
XWD 62, 122 ;R
XWD 63, 123 ;S
XWD 64, 124 ;T
XWD 65, 125 ;U
XWD 66, 126 ;V
XWD 67, 127 ;W
XWD 70, 130 ;X
XWD 71, 131 ;Y
XWD 72, 132 ;Z
XWD 73, 133 ;[
XWD 74, 134 ;\
XWD 75, 135 ;]
XWD 76, 136 ;^
XWD 77, 137 ;_
XWD 74, 140 ;` - no valid conversion
XWD 41, 141 ;a
XWD 42, 142 ;b
XWD 43, 143 ;c
XWD 44, 144 ;d
XWD 45, 145 ;e
XWD 46, 146 ;f
XWD 47, 147 ;g
XWD 50, 150 ;h
XWD 51, 151 ;i
XWD 52, 152 ;j
XWD 53, 153 ;k
XWD 54, 154 ;l
XWD 55, 155 ;m
XWD 56, 156 ;n
XWD 57, 157 ;o
XWD 60, 160 ;p
XWD 61, 161 ;q
XWD 62, 162 ;r
XWD 63, 163 ;s
XWD 64, 164 ;t
XWD 65, 165 ;u
XWD 66, 166 ;v
XWD 67, 167 ;w
XWD 70, 170 ;x
XWD 71, 171 ;y
XWD 72, 172 ;z
XWD 73, 173 ;{ - convert to [ (+0)
XWD 74, 174 ;| - no valid conversion
XWD 75, 175 ;} - convert to ] (-0)
XWD 74, 176 ;~ - no valid conversion
XWD 0, 177 ;Delete / HIGH-VALUE
XTDBLK: 3
Z
Z
SAVADR: BLOCK 1
RACS: BLOCK ^D16 ;SAVE ACS
C.END: END