Trailing-Edge
-
PDP-10 Archives
-
BB-H506D-SM_1983
-
cobol/source/cblio.mac
There are 23 other files named cblio.mac in the archive. Click here to see a list.
; UPD ID= 3578 on 6/10/81 at 2:36 PM by MAYBERRY
TITLE CBLIO FOR LIBOL V12B
;COPYRIGHT (C) 1974, 1981 BY
;DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
;
;
;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.
SUBTTL PICK UP UNIVERSALS AND SET UP JOBDAT.
SEARCH LBLPRM,COBVER ;DEFINE PARAMETERS.
%%LBLP==:%%LBLP
SEARCH COMUNI
%%COMU==:%%COMU
INFIX%
ISAM==:ISAM
EBCMP.==:EBCMP.
SEARCH FTDEFS ;FILE-TABLE DEFINITIONS
%%FTDF==:%%FTDF
IFN LSTATS,<
SEARCH METUNV
>
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>
LOC 124 ;.JBREN
EXP RENDP ;TO FORCE A DUMP.
LOC 137 ;.JBVER
EXP LBLVER
IFNDEF TOPS2X,<TOPS2X==0> ; [667] THIS CODE HAS NOT BEEN TESTED YET
IFNDEF SIRUS,<SIRUS==0> ; [403] SPECIAL CODE FOR SIRUS
IFNDEF SUPPTB,<SUPPTB==0> ; [403] SUPPRESS TRAILING BLANKS ON OUTPUT ASCII FILES.
IFNDEF ISTKS,<ISTKS==0> ;TYPE # OF IN'S AND OUT'S
SUPP==SIRUS!SUPPTB ; [403] SUPPRESS TRALING BLANKS FOR SIRUS
IFNDEF EBCMP.,<EBCMP.==0>
HISEG
SALL
MLON
SUBTTL CONSTANTS
;AC ASSIGNMENTS
FLG=7
C=11
I12=12
LVL=13
FLG1=14
I16=16
BUFLOC==4000 ;BUFFER LOCATION HAS BEEN ASSIGNED, LEFT-HALF OF F.WDNM(I16)
; FLAG BITS IN D.RFLG RIGHT HALF
SASCII==1 ; REQUEST FOR STANDARD ASCII, IN D.RFLG
RDDREV==2 ; OPEN REVERSED ACTIVE
FSTIDX==4 ;[605] FIRST ISAM READ IS SEQ, FOR IBS SCAN CODE
RDRVBK==10 ; READ REV BLOCKED GTR 10
RDLAST==20 ; = 1 IF LAST ISAM IO OPERATION WAS READ
SAVNXT==40 ; = 1 IF LAST I-O WAS DELETE OR REWRITE (NXT REC SAVED)
EXTOPN==100 ; =1 IF FILE WAS OPENED EXTEND
AFTADV==200 ; =1 IF LAST WRITE WAS AFTER-ADVANCING ("CR" BEFORE BFR-ADV)
;RPW BIT FOR TERMINATE HAS BEEN DONE ==400
INDASC==1000 ; =1 IF MTA STD ASCII NEEDS INDUSTRY-COMP MODE (TM03 TROUBLE)
; DON'T CLEAR AT CLOSE TIME
RF1CLR==376 ; BITS TO CLEAR AT CLOSE TIME
;RMSIO BITS: (DEFINED IN LBLPRM IN THE FUTURE)
LF%INP==1B33 ;FILE IS OPEN FOR INPUT
LF%OUT==1B34 ;FILE IS OPEN FOR OUTPUT
; USE PROCEDURE TABLE OFFSET VALUES
USESEC==5 ; USE PROCEDURE TABLE SECTION SIZE
EXTUSE==^D15 ; OFFSET TO EXTEND ERROR USE PRODECURE
;VALUES FOR FILE STATUS CODE
FSNRCF==23 ;NO RECORD FOUND ON READ,REWRITE,DELETE
;VALUES FOR FILE ACCESS MODE
%FAM.S==0 ;SEQUENTIAL
%FAM.R==1 ;RANDOM
%FAM.D==2 ;DYNAMIC
;[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
>
;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
;CONSTANTS FOR CONSTRUCTION OF ERROR NUMBERS
E.VOPE==^D100000000 ;COBOL VERB OPEN
E.VCLO==^D200000000 ; CLOSE
E.VWRI==^D300000000 ; WRITE
E.VREW==^D400000000 ; REWRITE
E.VDEL==^D500000000 ; DELETE
E.VREA==^D600000000 ; READ
E.VRET==^D700000000 ; RETAIN
E.VEXT==^D800000000 ; OPEN EXTEND
E.VSTR==^D900000000 ; START
E.MINP==^D1000000 ;MONITOR INPUT ERROR
E.MOUT==^D2000000 ; OUTPUT
E.MLOO==^D3000000 ; LOOKUP
E.MENT==^D4000000 ; ENTER
E.MREN==^D5000000 ; RENAME
E.MOPE==^D6000000 ; OPEN
E.MFOP==^D7000000 ; FILOP
E.MTAP==^D8000000 ; TAPOP.
E.FIDX==^D10000 ;ISAM INDEX FILE
E.FIDA==^D20000 ;ISAM DATA FILE
E.FSEQ==^D30000 ;SEQUENTIAL FILE
E.FRAN==^D40000 ;RANDOM FILE
E.FMTA==^D50000 ; LABEL PROCESSING ERROR (MTA FILE)
E.BSTS==^D1000 ;ISAM STATISTICS BLOCK
E.BSAT==^D2000 ;ISAM SAT BLOCK
E.BIDX==^D3000 ;ISAM INDEX BLOCK
E.BDAT==^D4000 ;ISAM DATA BLOCK
;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) AFTER RESET.
VLREBC==400000 ;VARIABLE LENGTH EBCDIC RECORDS
FILOPT==200000 ;FILE IS OPTIONAL
NONSTD==100000 ;LABELS ARE NON-STANDARD
STNDRD==40000 ;LABELS ARE STANDARD
MSTNDR==20000 ;STANDARD BUT MONITOR DOES LABEL PROCESSING
MTNOLB==10000 ;MOUNTR HANDLING LABELS,BUT NO LABELING
IFN TOPS20,<
F1CLR==7777 ; THESE FLAGS ARE CLEARED AT CLOSE TIME
>
IFE TOPS20,<
F1CLR==37777 ; THESE 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
FOPERR==2 ; FILOP.UUO FAILED
IFN ISAM,<
KEYSIZ==7777 ; MASK TO GET KEY SIZE FIELD OF ISAM KEY DESCRIPTOR
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
RIVK==1 ;READ, RERIT OR DELET INVALID-KEY
EIX==1 ;ENTER OF NAME.IDX IN PROGRESS
>
SUBTTL EXTERNALS.
ENTRY C.RSET ;MAKE SURE WE GET LOADED.
ENTRY DSPL.6,DSPL.7,DSPLY. ;FOR OVERLAYS
ENTRY METER.
IFN LSTATS,<
;ROUTINES IN METIO
EXTERN MRLSET,MRDMPT,MRDMP
;LOWSEG LOCATIONS
EXTERN MBTIM.,MRTMB.,MRTDBP
EXTERN MRBKO.,MRBLKO,MRBNUM
EXTERN MRFPGT,MRKILL,MROPTT,MRPSTM,MRRERN
>;END IFN LSTATS
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.,USETI.
EXTERNAL USETO.,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.,AINFO.,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 MOVE.,PD6.,PD7.,C.D6D7,C.D7D6
IFN EBCMP. <
EXTERNAL PD9.,C.D9D6,C.D9D7,C.D6D9,C.D7D9
>
EXTERNAL FRSTIC,LASTIC,PFRST.,UFRST.,ULAST.,IFRST.,ILAST.
EXTERNAL RELEN. ;[332]
EXTERN TODAY.,TODA1.
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 ;SIMULTANEOUS UPDATE
EXTERN FOP.BK,FOP.IS,FOP.DN,FOP.LB ;SIMULTANEOUS UPDATE
EXTERN SU.FRF ;FAKE READ FLAG
EXTERN .JBSA,.JBFF,.JBREL,.JBAPR,.JBTPC,.JBCNI,.JBDA,.JBOPC,.JBREN
IFN ISAM,<INTERN GDPSK> ;[447]SIMULTANEOUS UPDATE
INTERN CHTAB ;[455] SIMULTANEOUS UPDATE
INTERN SEQFIL ;[455] SIMULTANEOUS UPDATE
IFN ANS74,<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 SEEK.
EXTERN USEEK.
INTERN C.STRT,RDNXT.
EXTERNAL RET.1,RET.2,RET.3
INTERN DELET.,RERIT.,PURGE.
EXTERNAL HLOVL. ;[346] XWD HIGHEST OVERLAY LOC , LOWEST LOC
IFN ISAM,<EXTERNAL GD6.,GD7.,GD9.,GC3.,PD6.,PD7.,PD9.,PC3.,KEYCV.> ;[370]
IFN ISAM,<INTERN USOBJ,LVTST,LV2SK.,FOPIDX,NNTRY>
EXTERNAL FILES.,USES.,OVRFN.,TRAC1.
EXTERN FUSIA.,FUSOA.,FUSCP. ;[523] FILOP. ARG-BLOCK
INTERN LIBVR.,LIBSW.
IFN LSTATS,< ;EXTERNALIZE LIBOL METERING ROUTINES
INTERN LMETR.,MRACDP
IFN TOPS20,<
INTERN MRTM.S,MRTM.E
>
>
IFN ISAM,<
ADR==0
DEFINE TABADR(N,L) <
N==ADR
ADR==ADR+L
>
TABADR STAHDR,1 ;SIZE OF STATISTICS BLOCK IN SIXBIT BYTES
TABADR DDEVNM,1 ;DATA FILE'S DEVICE NAME
TABADR DFILNM,1 ;DATA FILE'S FILE NAME
TABADR DEXT,1 ;DATA FILE'S EXTENSION
TABADR DCDATE,1 ;DATA FILE'S CREATION DATE
TABADR DADATE,1 ;DATA FILE'S ACCESS DATE
TABADR MXLVL,1 ;NUMBER OF LEVELS IN INDEX FILE
TABADR DBF,1 ;DATA FILE BLOCKING FACTOR
TABADR DMTREC,1 ;NUMBER OF EMPTY RECORDS PER DATA BLOCK
TABADR EPIB,^D20 ;TWO WORDS PER INDEX LEVEL
;FIRST WORD: NUMBER OF ENTRIES PER INDEX BLOCK
;SECOND WORD: NUMBER OF EMPTY ENTRIES
TABADR DMXBLK,1 ;TOTAL BLOCKS IN DATA FILE
TABADR DMTBLK,1 ;EMPTY BLOCKS IN DATA FILE
TABADR IMXSCT,1 ;TOTAL SECTORS IN INDEX FILE
TABADR IMTSCT,1 ;EMPTY SECTORS IN INDEX FILE
TABADR FMTSCT,1 ;FIRST EMPTY SECTOR IN INDEX FILE
TABADR DMXREC,1 ;MAXIMUM DATA RECORD SIZE IN WORDS
TABADR DBPRK,1 ;BYTE POINTER TO RECORD KEY RELATIVE TO DATA RECORD
TABADR RWRSTA,1 ;NUMBER OF READ, WRITE, REWRITE STATEMENTS SINCE INITIALIZATION
TABADR IOUUOS,1 ;NUMBER OF IN'S AND OUT'S SINCE INITIALIZATION
TABADR SBLOC,1 ;RELATIVE ADR OF FIRST SAT BLOCK
TABADR SBTOT,1 ;TOTAL SAT BLOCKS
TABADR ISPB,1 ;INDEX FILE, SECTORS PER LOGICAL BLOCK
TABADR FILSIZ,1 ;MAXIMUM POSSIBLE NUMBER OF DATA BLOCKS IN FILE
TABADR KEYTYP,0 ;KEY-TYPE IN LEFT HALF
TABADR KEYDES,1 ;DESCRIPTION OF RECORD KEY
TABADR IESIZ,1 ;INDEX ENTRY SIZE IN WORDS
TABADR TOPIBN,1 ;TOP INDEX BLOCK NUMBER
TABADR %DAT,1 ;% OF DATA FILE EMPTY
TABADR %IDX,1 ;% OF INDEX FILE EMPTY
TABADR RECBYT,1 ;SIZE OF LARGEST DATA BLOCK IN BYTES
TABADR MAXSAT,1 ;MAX # OF RECORDS FILE CAN BECOME
TABADR ISAVER,1 ;"ISAM" VERSION NUMBER
TABADR PAGBUF,1 ;I/O SW.. 0 = SECTOR MULTIPLES, NONZERO = PAGES
STABL==ADR ;EQUALS SIZE OF STATISTICS BLOCK
TABADR IOWRD,14+1 ;TABLE OF DUMP MODE IOWD'S FOR EACH INDEX LEVEL
;0 DATA BLOCK
;1-12 INDEX BLOCKS
;13 SAT BLOCK
;14 STATISTICS BLOCK
TABADR OMXLVL,1 ;ORIGINAL MAX NUMBER OF LEVELS IN INDEX FILE
TABADR OKEYDS,1 ;[515] KEY DESCRIPTOR AT RESET TIME
TABADR ORCBYT,1 ;[515] RECORD SIZE AT RESET TIME
TABADR OEPIB,1 ;[515] ENTRIES PER INDEX BLOCK AT RESET TIME
TABADR CORE0,1 ;LAST,,FIRST - CORE AREA CLEARED AT CLOSE
TABADR ICHAN,1 ;CHANNEL NUMBER FOR INDEX DEVICE
TABADR USOBJ,14+1 ;USETI/O OBJECT: DATA, 10 INDEX, SAT & STA
INTERN CNTRY ;[650] MAKE INTERNAL FOR LSU
TABADR CNTRY,14+1 ;CURRENT INDEX ENTRY
TABADR NNTRY,14+1 ;FLAG, CNTRY POINTS TO NEXT ENTRY NOT CURRENT
TABADR LIVE,1 ;(-1) IF DATA NOT YET OUTPUT
TABADR BRISK,1 ;IF -1 OUTPUT ONLY WHEN INPUT IS EMINENT
TABADR CLVL,1 ;CURRENT LEVEL
IFN ANS74,<
TABADR RWDLKY,1 ; NNTRY,,ADDR OF CNTRY KEY COPYS FOR RWT/DEL
TABADR RCARSZ,1 ; ReCord ARea SiZe in words
TABADR RWDLRT,1 ; NNTRY,,Addr of RWDLKY during RETAIN
TABADR SVNXRT,1 ; Saves D.RFLG during RETAIN, when none zero flags that
; RWDLKY points to RETAINS del/rewrt key save area,
; that RWDLKY must be restored at the end of RETAIN
>
TABADR IAKBP,1 ;INDEX ADJUSTED SYMBOLIC KEY BYTE-POINTER
TABADR IAKBP1,1 ;POINTER TO SECOND KEY WORD
TABADR DAKBP,1 ;DATA ADJUSTED SYMBOLIC KEY BP
TABADR DAKBP1,1 ;POINTER TO THE SECOND KEY WORD
TABADR SINC,1 ;BINARY SEARCH INCREMENT
TABADR IBLEN,1 ;INDEX BLOCK LENGTH NOT COUNTING HEADERS
TABADR IKWCNT,1 ;INDEX, NUMBER OF WORDS IN THE KEY
TABADR DKWCNT,1 ;DATA, NUMBER OF WORDS IN KEY
TABADR FWMASK,1 ;MASK FOR FIRST WORD OF DATA KEY
TABADR LWMASK,1 ;MASK FOR LAST WORD OF DATA KEY
TABADR ICMP,1 ;HOLDS ADR OF THE INDEX COMPARE ROUTINE
TABADR DCMP,1 ;HOLDS ADR OF DATA COMPARE OR CONVERT ROUTINE
TABADR DCMP1,1 ;HOLDS ADR OF DATA COMPARE ROUTINE IF KEY IS NUMERIC DISPLAY
TABADR GDX.I,1 ; ADR OF CONVERT ROUTINE -- SK VS INDEX-ENTRY
TABADR GDX.D,1 ; ADR OF CONVERT ROUTINE -- SK VS DATA FILE KEY
TABADR GDPSK,1 ;PARAMETER FOR SYM-KEY CONVERSION
TABADR GDPRK,1 ;PARAMETER FOR REC-KEY CONVERSION
TABADR GDPRK1,1 ;
TABADR GETSET,1 ;DISPATCH LOC: ADJKEY OR GD67 OR FPORFP
TABADR RECBP,1 ;RECORD AREA BYTE-POINTER
TABADR RSBP,1 ;BYTE POINTER TO RECORD SIZE IN BUFFER
TABADR RSBP1,1 ;ANOTHER BP TO RECORD SIZE
TABADR LRW,1 ;FIRST FREE RECORD WORD, USED BY SETLRW
IFN ISTKS,<
TABADR INSSS0,1 ;EXP (LVL)INSSSS
TABADR OUTSS0,1 ;EXP (LVL)OUTSSS
TABADR INSSSS,16 ;NUMBER OF INS/LEVEL
TABADR OUTSSS,16 ;NUMBER OF OUTS/LEVEL
>
TABADR IOWRD0,1 ;POINTS TO CURRENT IOWRD
TABADR USOBJ0,1 ;POINTS TO CURRENT USOBJ
TABADR CNTRY0,1 ;POINTS TO CURRENT CNTRY
TABADR NNTRY0,1 ;FLAG, CNTRY POINTS TO NEXT ENTRY
TABADR BPSB,1 ;NUMBER OF BITS PER SAT BLOCK
ITABL==ADR-STABL ;INDEX TABLE LEN
TABADR BA,0 ;START OF BUFFER AREA
ISCLR1==IOWRD ;[432] [377] START OF ISAM SHARED BUFFER AREA TO SAVE
ISCLR2==ICHAN-1 ; [377] END OF ISAM SHARED BUFFER TO SAVE
ISMCLR==ISCLR2-ISCLR1 ; [377] DIFFERENCE OR SIZE OF AREA LESS 1 TO SAVE
> ;END OF 'IFN ISAM'
SUBTTL RESET
;RESET IS CALLED WITH A JSP 14,C.RSET
LIBVR.: EXP LBLVER ;LIBOL VERSION NUMBER
LIBSW.: EXP SWSET% ;LIBOL 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.
RUNTIM AC11, ;[346]GET THE RUNTIME.
MOVEM AC11,RUN.TM ;[346]SAVE IT.
IFN LSTATS,< ;(LSTATS) SAVE STARTING RUNTIME
IFE TOPS20,<
MOVEM AC11,MRPSTM ;SAVE RUNTIME AT START
>
IFN TOPS20,<
MTRJS% ;GET STARTING TICKS
ERJMP .+2 ;MOVE ZER0 IF NO CLOCK
DMOVEM AC1,MRPSTM ;SAVE VALUE
>
>;END IFN LSTATS
IFN DBMS,<
MOVE AC1,DBSTP%## ;GET FROM VISIBLE, BUT NOT SAFE PLACE
MOVEM AC1,DBSTP.## ;PUT IN INVISIBLE (FROM USER) BUT SAFE PLACE
SETZM DBSTP% ;CLEAN UP (ITS REALLY LEVEL.)
>
;;12B HACK - IN V13, THE FOLLOWING THREE LINES SHOULD BE DELETED
MOVE AC1,OVFLO.## ;COPY OVFLO. TO SLRSW.
MOVEM AC1,SLRSW.##
SETZM OVFLO. ;CLEAN UP
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]
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.
SKIPN AC10,%PUSHL(AC10) ;GET THE PDL SIZE.
MOVEI AC10,200 ;THIS IS FOR CSORT
MOVNI PP,(AC10) ;0,,-LENGTH
HRL PP,.JBFF ;START-LOC,,-LENGTH
MOVSS PP,PP ;POINTER IS SET UP.
MOVEI AC10,20(AC10) ;[660] LENGTH+20
ADDB AC10,.JBFF ;ADJUST .JBFF
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.
;SET FLAGS TO TRAP ON
RESET2: 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
IFN CSTATS,<
SKIPE METR.## ;METER--ING SETUP?
PUSHJ PP,SETMTR ;YES, SET UP FOR IT
>
IFN LSTATS,<
PUSHJ PP,MRLSET ;SETUP FOR LSTATS FILE WRITING
>
IFN ANS74,<
SKIPE RMFLG.## ;SKIP IF RMS NOT USED
PUSHJ PP,RMSGET## ; ** GO GET RMS **
>
SETOM OSHOOT## ;[530] SET END OF RESET FLAG
HRRZ AC10,COBSW. ;GET COMPILER ASSEMBLY SWITCHES
HRRZ AC3,LIBSW. ;GET LIBOL ASS-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.
CAIN AC10,7 ;TEST FOR 7.00 SERIES MONITOR
SETOM M7.00## ;SET FLAG IF TRUE
>
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: MOVE AC15,F.WDNM(I16);IF THIS IS FIRST
TLNN AC15,BUFLOC ;[316] TIME THROUGH TABLE,
PUSHJ PP,RSTFLG ;REORGANIZE THE FLAGS
LDB AC5,[POINT 4,UFRST.,12] ; GET CHAN FROM UUO
DPB AC5,DTCN. ;SAVE IT
MOVE FLG,F.WFLG(I16) ;GET THE FLAGS
HRLOI AC15,4077 ;[316] #OF DEVICES,,LOC OF FIRST ONE
AND AC15,F.WDNM(I16) ;
TLZE AC15,BUFLOC ;IS BUFLOC SET?
JRST RSTNFL ; [377A] YES-NEXT FILE
IFN ANS74,<
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
MOVSI AC15,BUFLOC ; 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
IFN ISAM,<
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
TLZ AC6,STNDRD!NONSTD ;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
COMPT. AC1, ;GET JFN *************
POPJ PP, ; ERROR RETURN
JRST RET.2 ; OK, 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
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: HRRZ AC2,D.RFLG(I16) ; GET STANDARD ASCII FLAG
TRO AC2,INDASC ; SET IT
HRRM AC2,D.RFLG(I16) ; AND PUT IT BACK
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: HRRZ AC3,D.RFLG(I16) ; GET SOME RUNTIME FLAGS
TRO AC3,SASCII ; SET STD-ASCII BIT
HRRM AC3,D.RFLG(I16) ; AND PUT IT BACK
; 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
CAIN AC6,77 ; [414] REALLY WANTS ONE?
SETOI AC6, ; [414] YES ONE BUFFER.
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
RSTDE3: CAML AC12,TEMP. ;BUFFER AREA
MOVEM AC12,TEMP. ;SAVE SIZE OF LARGER
;LOOP AGAIN
RSTLOO:
IFN ISAM,<TLNN FLG,IDXFIL >
AOBJN AC13,RSTDEV ;JUMP IF MORE DEV/FILTAB
RSTLO1: MOVSI AC15,BUFLOC ;[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
IFN ISAM,<
;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
TLNN AC6,STNDRD ;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: TLNN AC6,STNDRD ; LABELS STANDARD?
JRST RSTDE8 ;NO - MUST BE OMITTED
CAIGE AC10,^D20+4 ;
MOVEI AC10,^D20+4 ;LABEL RECORD IS THE LARGEST RECORD
RSTDE8: TLNN AC6,NONSTD ;SKIP IF NON-STANDARD LABELS
JRST RSTDE9 ;
HLRZ AC1,F.LNLS(I16) ;NONSTD LABEL SIZE
JUMPGE FLG,RSTD10 ;JUMP IF NOT ASCII
ADDI AC1,2 ;ADD IN "CR-LF" CHARS
IDIVI AC1,5 ;
RSTD10: TLNN FLG,DDMASC ;SKIP IF ASCII
IDIVI AC1,6 ;
SKIPE AC2 ;
ADDI AC1,1 ;CONVERT CHARS TO WORDS
CAIGE AC10,3(AC1) ;
MOVEI AC10,3(AC1) ;ENSURE LABEL REC WILL FIT IN REC AREA
RSTDE9: MOVEI AC1,-3(AC10) ;
HRRM AC1,D.LRS(I16) ;SAVE IT FOR OPNNSB
LDB AC12,F.BNAB ;NUMBER OF ALTERNATES
CAIN I12,77 ; [414] REALLY WANTS ONE?
JRST RSTD11 ; YES, DON'T MULTIPLY
IFN ANS68,<
IMULI AC10,DFLTBF(I12) ; NO,REC TIMES NUMBER OF ALTERNATE BUFFERS
>
IFN ANS74,<
REPEAT 0,< ;V13 INCOMPATIBLE CODE - NEEDS COMPILER CHANGE
JUMPN AC12,.+2 ; SKIP IF NOT ZERO RESERVED
MOVEI AC12,DFLTBF ; 0 MEANS DEFAULT NUMBER
IMULI AC10,(I12) ; NO,REC TIMES NUMBER OF BUFFERS
>
REPEAT 1,< ;COMPATIBLE WITH 12A
IMULI AC10,DFLTBF(I12) ; NO,REC TIMES NUMBER OF ALTERNATE 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
IFN ANS68,<
ADDI AC10,12 ;3+7=12 FLAG WORDS REQD FOR RANDOM OR IO
>
IFN ANS74,<
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
IFE ISAM,<
RERIT.: OUTSTR [ASCIZ /REWRITE ?/]
SKIPA
DELET.: OUTSTR [ASCIZ /DELETE ?/]
RSTIDX: OUTSTR [ASCIZ /
To process ISAM files CBLIO must be reassembled with the conditional
assembly switch,ISAM, equal to a non-zero value./]
JRST KILL
>
IFN ISAM,<
;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 2,F.WFLG(AC12),17]; [377A] GET ACCESS MODE
CAIE AC0,2 ; [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
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,600130 ;INVALID SMU ACCESS?
JRST [OUTSTR [ASCIZ /RESET time /]
JRST OCPERR ]
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
COMPT. AC1, ;OPEN FILE IN FROZEN MODE
JRST [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: HLLZ AC1,D.F1(I16) ;[377] GET FLG1 PARMS
TLNN AC1,FILOPT ;[374] OPTIONAL FILE?
JRST RSTID8 ;[323] NO, FATAL
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
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
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
IFN ANS68,<
IMULI AC4,3 ;RESERVE 3 KEY AREAS
>
IFN ANS74,<
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:
IFN ANS68,<
MOVEI AC4,6 ;(1+1)*3
TRNN AC6,1 ;ODD = 1 WRD, EVEN = 2 WRDS
MOVEI AC4,9 ;(2+1)*3
>
IFN ANS74,<
MOVEI AC4,12 ; (1+1)*5
TRNN AC6,1 ; ODD = 1, EVEN = 2
MOVEI AC4,17 ; (2+1)*5
>
RSTID3:
IFN ANS68,<
ADDI AC12,2(AC4) ;NUMBER OF WORDS ALLOCATED
>
IFN ANS74,<
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
IFN ANS74,<
; 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
>; END IFN ANS74
;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
IFN ANS74,<
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 = FILE NAME
SETOVR: 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
;ROUTINE TO REORGANIZE THE FLAGS
RSTFLG: MOVE FLG,F.WFLG(I16) ;GET FLAGS
MOVX AC15,BR%IO!BR%RER!BR%RRC
AND AC15,FLG ;RRUNER & RRUNRC
LDB AC1,[POINT 3,FLG,9]
HLLZ AC2,FLGTAB(AC1) ;DEVICE DATA MODE
TLZ AC2,037777 ;
IOR AC15,AC2 ;
MOVEI AC0,SASCII ; GET STANDARD ASCII FLAG
CAIN AC1,4 ; AND SET IT IF REQUESTED
IORM AC0,D.RFLG(I16) ; DOIT
LDB AC1,[POINT 2,FLG,15]
HLLZ AC2,FLGTAB(AC1) ;CORE DATA MODE
TLZ AC2,777707 ;
IOR AC15,AC2 ;
LDB AC1,[POINT 2,FLG,17]
HLLZ AC2,FLGTAB(AC1) ;ACCESS MODE
TLZ AC2,777770 ;
IOR AC15,AC2 ;
TXNE FLG,BR%OPF ;FILOPT?
TRO AC15,FILOPT ;
TXNE FLG,BR%NSL ;NONSTD?
TRO AC15,NONSTD ;
TXNE FLG,BR%STL ;STNDRD?
TRO AC15,STNDRD ;
TLNN AC15,DDMEBC ;ONLY EBCDIC HAS VAR-LEN RECORDS
JRST RSTFL1 ;
TXNE FLG,BR%VLE ;VARIABLE LENGTH EBCDIC RECORDS?
TRO AC15,VLREBC ;
RSTFL1: HLLM AC15,F.WFLG(I16);SAVE IT
HRLM AC15,D.F1(I16) ;FLG1
TLNE FLG,RRUNER!RRUNRC ;RERUNING?
SETOM TEMP.2 ;YES, REMEMBER TO TURN OFF CHAN 17
POPJ PP, ;
;BITS 0-3 DEVICE DATA MODE
; 12-14 CORE DATA MODE
; 15-17 ACCESS MODE
FLGTAB: 200022,,0
040001,,0
400044,,0
100010,,0
400000,,0 ; STANDARD ASCII
Z
Z
Z
;TRAP INTERUPT ROUTINE
TRAP.:
IFE TOPS20,<
PORTAL .+1 ; SET EXECUTE ONLY ENTRY POINT
>
SKIPE INTRAP## ;ARE WE ALREADY IN A TRAP?
EXIT ;YES, JUST QUIT
SETOM INTRAP## ;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.: TTCALL 3,[ASCIZ "?LBLADP Attempt to drop off end of program."]
JRST KILL.
KDECL.: TTCALL 3,[ASCIZ "?LBLADD Attempt to drop off end of DECLARATIVES."]
JRST KILL.
ILLC.: TTCALL 3,[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.:
IFN LSTATS, SETOM MRKILL ;NOTE PROGRAM WAS ABORTED
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
TLNE FLG,OPNOUT ;[622][444] OPEN FOR OUTPUT
TLNE FLG,OPNIN ;[622][444] YES, OPEN FOR OUTPUT ONLY
JRST KILL4 ;[444] NO, CHECK NEXT ONE
MOVE AC13,D.DC(I16) ;[444] GET DEV CHARACTERISTICS
TXNN AC13,DV.DSK ;[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
LDB AC4,DTCN. ;[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
IFN ANS68,<
TLNE FLG,OPNIN+OPNOUT; IF THE FILE IS OPEN
PUSHJ PP,C.CLOS ; CLOSE IT
>;END IFN ANS68
IFN ANS74,<
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:>;END IFN ANS74
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 CSTATS,<
SKIPE METR.## ;WERE METER POINTS ENABLED?
PUSHJ PP,WRTMET ;YES, WRITE THE FILE
>
IFN LSTATS,<
PUSHJ PP,MRDMPT ;DUMP ALL LSTATS DATA
>
IFN DBMS,<
SKIPE DBSTP. ;IGNORE IF BEFORE VERSION 12A
PUSHJ PP,@DBSTP. ;CLEANUP DBMS
>
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
IFN ANS68,<
OUTSTR [ASCIZ /
COBOL-68 /]
>
IFN ANS74,<
OUTSTR [ASCIZ /
COBOL-74 /]
>
MOVE AC12,COBVR. ;GET COBOL VERSION NUMBER
PUSHJ PP,VEROU0 ;TYPE VERSION NUMBER IN STANDARD FORMAT
IFN ANS68,<
OUTSTR [ASCIZ /, LIBOL /]
>
IFN ANS74,<
OUTSTR [ASCIZ /, C74OTS /]
>
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
>
IFN ANS74,<
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.
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,4 ;[437]
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 SEEK VERB
;A SEEK VERB LOOKS LIKE:
;FLAGS,,ADR ADR = FILE TABLE ADDRESS
;CALL+1: ;POPJ RETURN
SEEK.:
IFN ANS68,<
MOVE FLG,F.WFLG(I16) ;FLAG REGISTER
TLNE FLG,RANFIL ;SKIP IF NOT A RANDOM FILE
TLNN FLG,OPNIN!OPNOUT ;SKIP IF RANDOM FILE IS OPEN
POPJ PP, ;EXIT TO ***ACP***
HLRZ I12,D.BL(I16) ;SET UP FOR FLIMIT
PUSHJ PP,FLIMIT ;CHECK THE FILE LIMITS
;INVALID KEY RETURNS TO ***ACP***
MOVE AC1,AC4 ;ACTUAL KEY
PUSHJ PP,SETCN. ;SET UP CHANNEL NUMBER
XCT USETI. ;
XCT USEEK. ;SEEK UUO
>
POPJ PP, ;EXIT TO ***ACP***
;FORCE A CALL TO RRDMP
RENDP: SETOM REDMP. ;
JRSTF @.JBOPC ;CONTINUE
;RESTORE .JBSA, .JBREN - DESTROYED BY RERUN'S GETSEG
RSAREN: HRR AC2,RESET1
HRRM AC2,.JBSA
MOVEI AC2,RENDP
MOVEM AC2,.JBREN
POPJ PP,
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 (LSTATS ALSO)
;AC2= ;LSTATS ARG REGISTER
;AC4= ;BLANK COUNTER (TO SUPPRESS TRAILING BLANKS)
;AC12 ;MUST NOT BE USED
DOPFS.: POINT 10,(I16),17 ;DISPLAY OPERAND FIELD SIZE
DSPLY.:
IFN LSTATS,<
MOVEI AC2,MB.DSP ;INDICATE DISPLAY METER POINT
PUSHJ PP,MRACDP ;SET METER POINT (CLEARS AC2)
>
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. ; .
PUSHJ PP,OUTBF. ;DUMP BUFFER
IFN LSTATS,<
MRTME. (AC1) ;END METER TIMING
>
POPJ PP, ; 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: PUSHJ PP,OUTBF. ; OUTPUT BUFFER AND EXIT
IFN LSTATS,<
MRTME. (AC1) ;END METER TIMING
>
POPJ PP,
;HERE FOR DISPLAY OF SIXBIT DATA
DSPL.6:
IFN LSTATS,<
MOVEI AC2,MB.DSP ;INDICATE DISPLAY METER POINT
PUSHJ PP,MRACDP ;SET METER POINT (CLEARS AC2)
>
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:
IFN LSTATS,<
MOVEI AC2,MB.DSP ;INDICATE DISPLAY METER POINT
PUSHJ PP,MRACDP ;SET METER POINT (CLEARS AC2)
>
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
MRTME. (AC1) ;END METER TIMING
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:
IFN LSTATS,< ;LIBOL METER TIMING
SKIPE F.WSMU(I16) ;SKIP TIME START IF SIM. UPDATE
JRST C.OMRX ;SKIP
MRTMS. (AC1) ;START OPEN TIMING
C.OMRX:>;END IFN LSTATS
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
HRRZ AC0,D.RFLG(I16) ; GET FLAGS
; BL/10/27/80 TRO AC0,AFTADV ; SET SO BFR-ADV WILL WRITE "CR" FIRST
TRZ AC0,AFTADV ;RESET SO BFR-ADV WILL NOT WRITE 'CR' FIRST ;BL
HRRM AC0,D.RFLG(I16) ; RESET IT
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 FLG1,FILOPT ;IS FILE OPTIONAL?
JRST OPNOP ;YES. RETURNS ONLY IF PRESENT
OPNSBA: PUSHJ PP,DEVIOW ;RESET THE DEVICE IOWD
IFN ANS68,<
TLNE FLG,RANFIL ;SKMFILE
PUSHJ PP,OPNSFL ;STORE THE FILE LIMITS SO HE CAN'T DIDDLE
>
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,[POINT 1,F.RMS(AC4),7] ;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,^D12 ;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,^D30 ;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,^D31 ;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
OPNOP: TLNE FLG,OPNOUT ;SKIP IF NOT OUTPUT
JRST OPNSBA ;OUTPUT FILES ARE NOT OPTIONAL
PUSHJ PP,$SIGN ;[277] OUTPUT "$" FOR .OPERATOR
OUTSTR [ASCIZ /Is /] ;OPTIONAL FILE PRESENT?
PUSHJ PP,MSFIL.
OUTSTR [ASCIZ / present? .../]
PUSHJ PP,YES.NO ;SKIP RETURN IF "NO" ANSWER
JRST OPNOP1 ;YES
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************
OPNOP1: TLNN FLG,IDXFIL ;ISAM FILE?
JRST OPNSBA ;NO
MOVE AC1,D.OPT(I16) ;WERE THE BUFFERS SETUP AT RESET TIME?
AOJN AC1,OPNSBA ;EXIT HERE IF THEY WERE
MOVEI AC0,^D29 ;ERROR NUMBER
PUSHJ PP,OXITP ;DOESN'T RETURN IF IGNORING ERRORS
OUTSTR [ASCIZ /Either the ISAM file does not exist or
the VALUE OF ID changed during the program./] ;[374]
PUSHJ PP,KILL ;AND DONT RETURN
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) ;
IFN ISAM,<
TLNE FLG,IDXFIL ;IF INDEX FILE
AOBJP AC0,.+1 ; POINT AT DATA DEVICE
>
MOVEM AC0,D.ICD(I16) ;
POPJ PP, ;
IFN ANS68,<
;SET THE FILE LIMIT CLAUSES IN THE FILE-TABLE. ***POPJ***
OPNSFL: LDB AC5,F.BNFL ;NUMBER OF FILE LIMIT CLAUSES
JUMPE AC5,RET.1 ;RETURN IF NONE
MOVNS AC5 ;
HRL AC1,AC5 ;
HRRI AC1,F.WLHL(I16) ;IOWD NUMBER OF,, FILE LIMIT
HLR I12,D.BL(I16) ;PICK UP THE BUFFER LOCATION
MOVEM AC1,R.FLMT(I12) ;
OPNSF1: MOVE AC5,(AC1) ;LIMIT,,LIMIT
MOVE AC6,(AC5) ;
MOVSS AC5 ;
MOVE AC4,(AC5) ;
CAMLE AC4,AC6 ;SKIP IF AC4 IS THE LOW LIMIT
EXCH AC4,AC6 ;
MOVEM AC4,1(AC1) ;LOW LIMIT
MOVEM AC6,2(AC1) ;HIGH LIMIT
ADDI AC1,2 ;ACCOUNT FOR TWO WORDS
AOBJN AC1,OPNSF1 ;GO AGAIN IF YOU CAN
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
PUSHJ PP,DEVCHR ;GET THE DEVICE CHAR.
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,^D14 ;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,^D55 ; 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: HRRZ AC0,D.RFLG(I16) ; YES,GET RUN FLAGS
TRO AC0,EXTOPN ; SET OPEN WAS EXTEND
HRRM AC0,D.RFLG(I16) ; AND PUT IT BACK
TXNE AC13,DV.MTA ;MTA?
TLZ FLG1,STNDRD!NONSTD ;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,^D16 ;ERROR NUMBER
JRST OXITER ;COMPLAIN
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,^D17 ;ERROR NUMBER
JRST OXITER ;COMPLAIN
OPNDE7: TXNE AC13,DV.DSK ;SKIP IF DEVICE IS NOT A DSK
JRST OPNCHN ;FIND A FREE CHANNEL
MOVE AC2,[BYTE (5)10,2,4,20,17]
MOVEI AC0,^D15 ;ERROR NUMBER
JRST OXITER ;COMPLAIN
DEVCHR: 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
DEVCH1: MOVEM AC13,D.DC(I16) ;[330] SAVE THE CHARACTERISTICS
JUMPN AC13,RET.1
MOVE AC2,[BYTE (5)10,2,4,20,13] ;FCBO,DINAD.
POP PP,(PP) ;POP OFF THE RETURN
MOVEI AC0,^D18 ;ERROR NUMBER
JRST OXITER ;COMPLAIN
;FIND A FREE DEVICE CHANNEL AND SETUP THE BUFFERS
;XCT OPEN, INBUF AND/OR OUTBUF ***OPNBSI***
OPNCHN: PUSHJ PP,GCHAN ;LOAD AC5 WITH A CHANNEL NUMBER
DPB AC5,DTCN. ;SAVE IT
IFN ISAM,<
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
TLNE FLG,DDMASC ;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
IFN ISAM,<
TLNN FLG,IDXFIL ;ISAM ?
JRST OPNCH3 ;NO
MOVE AC1,F.WDNM(I16) ;ADR
MOVE AC1,(AC1) ;IDX DEVICE NAME
MOVEM AC1,UOBLK.+1 ;
OPNCH3:>
TXNN AC16,OPN%EX ;OPEN EXTENDED?
JRST OPNC3A ; NO
OPNC3B: PUSHJ PP,OPNFOP ; [431] YES OPEN FILE VIA FILOP
JRST OFERRI ; [576] [431] ERROR RETURN
JRST OPNC41 ; CONT NORMALLY
OPNC3A: SKIPN F.WSMU(I16) ; SKIP IF SIMULTANEOUS UPDATE
JRST OPNC31 ; NO, CONT
IFE TOPS20,<
JRST OPNC3B ; OPEN VIA FILOP
>
IFN TOPS20,<
OPNC3C: PUSHJ PP,OCPT ; [431] OPEN FILE VIA DEC-SYS-20 COMPT.
IFN ANS74,<
JRST OCPER ; ERROR FOR 74,FNF IS ALSO ERROR
>
IFN ANS68,<
TRNA ;ERROR, CHECK FOR FNF
>
JRST OPNC41 ; CONT NORMALLY, ALL OK
IFN ANS68,<
TLNE FLG,IDXFIL ;IS IT AN ISAM FILE
JRST OCPER ;YES, GIVE THE 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: MOVX AC1,GJ%SHT ;DO FILE CREATE OPEN
MOVEM AC1,CP.BK1
MOVE AC1,[10,,CP.BLK]
COMPT. AC1, ;DO IT
JRST OCPER ;FAILED AGAIN, SCREW IT
JRST OPNC41 ;GOOD CONTINUE WITH NEW FILE
>;END IFN ANS68
>;END IFN TOPS20
OPNC31:
IFN TOPS2X,<
TLNN FLG,OPNOUT ;[667] IF INPUT (READ) ONLY
TXNN AC13,DV.DSK ;[667] FOR A DSK FILE
TRNA ;[667] NO
JRST OPNC3C ;[667] YES, USE COMPT. WITH OF%RDU ON
>
IFE TOPS20,<
TXNN AC13,DV.MTA ; SKIP IF A MTA
JRST OPC31X ; ELSE CONT
; 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: TLZ FLG1,STNDRD!NONSTD ; 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: MOVE AC0,[E.MTAP+^D54] ; 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
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 ALTERNATE BUFFERS (FOR INBUF X,2(AC6))
IFE TOPS20,< ;[561]
TXNE AC13,DV.MTA ;SKIP IF NOT A MTA
> ;[561]
IFN TOPS20,<
TXNN AC13,DV.MTA ;[561] MTA??
JRST OPNC4X ;[561] 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]
OPNC4D:
>;END IFN TOPS20
JUMPN AC5,OPNNSB ;[561] NON STANDARD BUFFER SETUP
OPNC4X: ;[561]
IFN ISAM,<
TLNE FLG,IDXFIL ;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
CAIN AC6,77 ; [414] REALLY WANTS ONE?
SETOI AC6, ; [414] YES, ONE BUFFER.
TXNE AC16,OPN%EX ;APPEND?
JRST OPNC45 ;YES, DO FILOP NOW
TLNE FLG,OPNIN ;INPUT?
XCT UIBUF. ;**********
TLNE FLG,OPNOUT ;OUTPUT?
XCT UOBUF. ;**********
JRST OPNC46
OPNC45: MOVEI AC1,2(AC6) ;GET NO. OF BUFFERS
HRLZM AC1,FOP.BN## ;SET 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 PERVIOUS 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 DENISTY 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,^D49 ; 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
MOVE AC0,[E.MTAP+^D50] ; 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,^D51 ; 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
MOVE AC1,[7,,FOP.BK]
FILOP. AC1,
JRST [ POP PP,(PP) ; DISCARD OPNEXT RETURN
LDB AC0,F.BBKF ; GET BLOCKING FACTOR
JUMPN AC0,OFERR ; JUMP IF BLOCKED
POP PP,(PP) ; DISCARD .JBFF SAV
JRST OFERR ] ; FAILED
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
JUMPN AC2,ZROBUF ;[507] CLEAR ANY POSSIBLE PREVIOUS JUNK
POP PP,.JBFF ;RESTORE .JBFF
OPNCH2:
IFN ANS74,<
TLNN FLG,IDXFIL!RANFIL!OPNIN ;[622]
TLNN FLG,OPNOUT ;TEST FOR SEQ. OUTPUT
JRST OPNC21 ;NO
SKIPN F.LCP(I16) ;LINAGE-COUNTER?
JRST OPNC21 ;NO
MOVEI AC6,1
MOVEM AC6,F.LCP(I16) ;YES, SET TO 1
OPNC21:>
TXNE AC13,DV.DIR ;SKIP IF NON-DIRECTORY DEVICE
TLNE FLG1,STNDRD ;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,^D19 ;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: CAIN AC6,77 ;[477] REALLY WANTS ONE BUFFER?
SETO AC6, ;[477] YES, SET TO DEFAULT TO 1
ADDI AC6,2 ;ALTERNATE PLUS 2 DEFAULT BUFFERS
TLNE FLG1,STNDRD+NONSTD ;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?
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
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
IFN ANS68,<
HRLI AC6,R.FLMT(I12) ;LOC-1,,-N
>
IFN ANS74,<
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
IFN ANS68,<
HRRI AC6,1+R.FLMT(I12);FIRST DATA WORD
>
IFN ANS74,<
SETZM R.DLRW(I12) ; CLEAR DEL/RWT SAVE BLK NUM
HRRI AC6,1+R.DLRW(I12);FIRST DATA WORD
>
TLNE FLG1,VLREBC ; 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
IFN ISAM,<
;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 TOPS2X,<
TLNE FLG,IOFIL!OPNOUT ;[667] IF OPEN READ ONLY OR
>
SKIPE F.WSMU(I16) ; SIMULTANEOUS UPDATE?
JRST OPNIX2 ; YES
;IFN TOPS20,< ;[570]
; TLNE FLG,IOFIL!OPNOUT ;[570] OPEN READ ONLY?
; JRST ONIX1A ;[570] NO, DO LOOKUP
; PUSHJ PP,OCPT ;[570] YES, OPEN IN THAWED MODE
; JRST OCPER ;[570] ERROR IN THAWED OPEN
; JRST OPNIX2 ;[570] OK,CONT
;ONIX1A: >;[570] END IFN TOPS20
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
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 ;
MOVE 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./]
PUSHJ PP,SETIC ;SET UP IGETS CHANNEL NO.
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
SKIPN F.WSMU(I16) ; SIMULTANEOUS UPDATE?
IFN TOPS2X,<
TLNN FLG,IOFIL!OPNOUT ;[667] IF OPEN READ ONLY OR
TRNA ;[667] YES
>
JRST OPNI21 ; NO
IFE TOPS20,<
PUSHJ PP,OPNFPD ; [431] OPEN FILE VIA FILOP UUO
JRST OFERR ; [576] [431] ERROR RETURN
>; [431] END IFE TOPS20
IFN TOPS20,<
PUSHJ PP,OCPTD ; [431] OPEN FILE VIA DEC-SYS-20 COMPT.
JRST OCPERI ; [431] ERROR RETURN
>; [431]END IFN TOPS20
JRST OPNI22 ; SKIP THE OPEN UUO
OPNI21: XCT UOPEN. ;OPEN THE DATA FILE
JRST OERRDF ;ERROR RETURN
;SETUP IOWRD TABLE
OPNI22:
IFN ANS74,<
; Set record area length for START
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
>; end ifn ans74
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: ; [375]
OUTSTR [ASCIZ /Users maximum record size /] ; [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: ;[371]
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
CAMN AC6,DBPRK(I12) ;[574] MUST BE SAME AS FILE OPENED
JRST OPNI7B ; ELSE 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,F.WBRK(I16) ;[617] PUT WORD OFFSET OF KEY IN AC10
HRRZ AC6,DBPRK(I12) ;[617] PUT ISAM-GENERATED WORD OFFSET IN AC6
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
IMULI AC10,(AC3) ;[617] CALC NUMBER BYTES TO KEY (FULL WDS)
ADD AC10,AC1 ;[617] PLUS PARTIAL = BYTES TO KEY FOR PROGRAM
CAIN AC6,(AC10) ;[617] IS THE BYTE OFFSET TO THE KEY THE SAME??
JRST OPNI7B ;[617] YES, CONT
;[617] NO, TOO BAD
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
OPNI7B: PUSHJ PP,OPNWPB ;AC5 = BLKFTR, AC10 = WPB
;BL; 2 LINES INSERTED AT OPN17B + 1 TO FIX ISAM/RANDOM SHARED BUFFR BUG
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
LSH AC10,-9 ; ROUND
LSH AC10,9 ; OFF
OPNI7E: MOVE AC6,DBF(I12) ;DATA FILE BLOCKING FACTOR VIA STA BLOCK
CAMN AC5,AC6 ;AC5 = BLKFTR VIA FILE TABLE
JRST OPNI05 ;OK
MOVE AC0,[E.FIDX+^D9] ;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: 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
;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
; FOR ANS74 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
IFN ANS74,<
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: 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 SYMKEY
TLZ AC1,770000 ;MASK
HLLZ AC2,F.WBSK(I16) ;
TLZ AC2,7777 ;
IOR AC1,AC2 ;SYM-KEY BYTE RESIDUE
MOVEM AC1,GDPSK(I12) ;GD PARAMETER FOR SYM-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) ; SYM-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) ; SYM-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,^D30 ;PERMANENT ERROR
MOVEM AC0,FS.FS ;LOAD FILE-STATUS
MOVE AC0,[E.FIDX+^D7] ;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,^D30 ;PERMANENT ERROR
MOVEM AC0,FS.FS ;LOAD FILE-STATUS
MOVE AC0,[E.FIDX+^D8] ;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
IFN ISAM,<
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:
IFN ISAM,<
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
TLNE FLG1,VLREBC ;[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
TRNN AC1,INDASC ; IS IT INDUSTRY-COMP ASCII?
JRST OPNBS0 ; NO,CONT
; HERE FOR STD-ASCII WITH INDUSTRY COMPAT. MODE
MOVEI AC6,^D8 ; SET 8 BIT BYTES
JRST OPNBS2 ; AND INDUSRTY COMPAT-MODE
OPNBS0: 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.
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
HRR 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
TLNE FLG1,VLREBC ; 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 TOPS2X,<
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
>
SKIPE F.WSMU(I16) ;OR SIMULTANEOUS UPDATE?
JRST OPNLU2 ;[565] YES, DON'T DO LOOKUP
IFN ANS74,<
TLNN FLG,OPNIN!IDXFIL; SKIP IF ISAM OR INPUT FILE
PUSHJ PP,OPNENT ; SUPERSEDE THE EXISTING FILE
>
;IFN TOPS20,< ;[570]
; TLNE FLG,IOFIL!OPNOUT ;[570] OPEN READ ONLY?
; JRST ONCLPA ;[570] NO, DO LOOKUP
; LDB AC1,DTIBS. ;[570] GET I-O BYTE SIZE
; PUSH PP,AC1 ;[570] SAVE IT
; ;[570] THIS IS NECESSARY BECAUSE
;*** IF THIS IS EVER USED AGAIN,THE INPUT BUFFER CONTROL
;*** BLOCK (D.IBH,D.IBB,D.IBC) MUST BE SAVED HERE
;*** AND LATER RESTORED.
; ;[570] THE COMPT. UUO CRUNCHES IT
; PUSHJ PP,OCPTNW ;[570] YES, OPEN IN THAWED MODE
; JRST [POP PP,(PP) ;[570] GET RID OF BYTE SIZE
; JRST OCPER] ;[570] ERROR IN THAWED OPEN
; POP PP,AC1 ;[570] GET I-O BYTE SIZE
; DPB AC1,DTIBS. ;[570] RESTORE INPUT BYTE SIZE
; DPB AC1,DTOBS. ;[570] RESTORE OUTPUT BYTE SIZE
; JRST OPNLU2 ;[570] CONT WITHOUT LOOKUP
;ONCLPA: >;[570] END IFN TOPS20
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
;IF METERING STORE SIZE OF FILE RETURNED BY LOOKUP
IFN LSTATS,<
TLNE FLG,OPNOUT ;[622] OPEN READ ONLY?
JRST OPNLU3 ; NO, GO ON
LDB AC1,DTCN. ; YES,GET CHANNEL NUMBER
MOVE AC1,MROPTT(AC1) ; GET FILE BLOCK ADDRESS
HLRE AC2,ULBLK.+LKPSIZ ; GET FILE SIZE RETURNED BY LOOKUP
MOVEM AC2,MB.FSZ(AC1) ; SAVE LOOKUP TIME FILE SIZE
>;END IFN LSTATS
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
IFN BIS,<
DMOVE AC0,ARGBK.+.RBEXT ;[612] GET EXTENSION, DATE AND PROTECTION BITS
DMOVEM AC0,ULBLK.+1 ;[612] INTO SHORT LOOKUP BLOCK.
>
IFE BIS,<
MOVE AC0,ARGBK.+.RBEXT ;[612] GET EXTENSION AND DATE BITS
MOVEM AC0,ULBLK.+1 ;[612] INTO SHORT LOOKUP BLOCK.
MOVE AC0,ARGBK.+.RBPRV ;[612] ALSO PROTECTION AND BITS
MOVEM AC0,ULBLK.+2 ;[612] INTO SHORT 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
IFN BIS,<
DMOVE AC0,ULBLK. ;FILE NAME & EXTENSION
>
IFE BIS,<
MOVE AC0,ULBLK. ;FILE NAME
MOVE AC1,ULBLK.+1 ;EXTENSION
>
IFE TOPS20,<
TXNE AC13,DV.DTA ;SKIP IF NOT A DTA
HRRM AC1,D.CBN(I16) ;SAVE AS THE FIRST BLOCK NUMBER
>
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,TODA1. ;CREATION DATE
SETZ AC1, ;
ROTC AC0,6 ;
MOVEM AC0,STDLB.+7 ;DATE
MOVEM AC1,STDLB.+6 ;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
;IF METERING STORE SIZE OF FILE RETURNED BY LOOKUP
IFN LSTATS,<
LDB AC1,DTCN. ;GET CHANNEL NUMBER
MOVE AC1,MROPTT(AC1) ;GET FILE BLOCK ADDRESS
MOVEM AC5,MB.FSZ(AC1) ;PUT SIZE INTO FILE BLOCK BUCKET
>;END IFN LSTATS
JUMPGE AC5,OPNEL4 ;[565] SKIP AHEAD IF LOOKUP RETURNS BLKS
MOVNS AC5 ;[565] NEGATE LOOKUP NUMBER OF WRDS
ADDI AC5,177 ;[565] DIVIDE WORDS WRITTEN BY
IDIVI AC5,200 ;[565] WRDS/BLK AND ROUND UP
JRST OPNEL4 ;[565] CONT CALC.
OPNEL2: MOVE AC5,ARGBK.+.RBSIZ ; GET LAST BLOCK OF FILE
;IF METERING STORE SIZE OF FILE RETURNED BY EXTENDED LOOKUP
IFN LSTATS,<
LDB AC1,DTCN. ;GET CHANNEL NUMBER
MOVE AC1,MROPTT(AC1) ;GET FILE BLOCK ADDRESS
MOVNM AC5,MB.FSZ(AC1) ;PUT SIZE INTO FILE BLOCK BUCKET
;MAKE NEGATIVE TO SHOW ITS WORDS
>;END IFN LSTATS
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,^D30 ;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
IFN ANS74,<
;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
>;END IFN ANS74
;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
IFN ISAM,<
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: >;END IFN ISAM
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
TDNA ;[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
IFN ANS74,<
POPJ PP, ; ERROR RETURN FOR 74
>
IFN ANS68,<
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
MOVE AC1,[7,,FOP.BK] ;[576]RESTORE FILOP ARG
JRST .+1 ] ;[576]NON ISAM FILE NOT FOUND,WILL CREATE ONE
>;END IFN ANS68
IFN ISAM,<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
IFE ISAM,<TLO FLG1,FOPERR> ; FILOP. FAILED
IFN ISAM,<
OFERRI: MOVEI AC0,^D30 ;GET FILE-STATUS CODE = PERM. ERROR
MOVEM AC0,FS.FS ;SET IT UP
MOVE AC0,[E.MFOP+E.FIDX] ;MAKE AN ERROR NUMBER
TLON FLG1,FOPIDX ; REMEMBER IT'S A FILOP ERROR
MOVE AC0,[E.MFOP+E.FIDA]
TLNN FLG,IDXFIL ; ISAM FILE?
>;END IFN ISAM
MOVE 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,FID.PT
EXTERN FID.BK,TMP.BK,TMP.PT
E.MCPT==^D8000000 ; [431] MONITOR COMPT. UUO ERROR
; [431]HERE IF THIS IS A DECSYSTEM-20 TO OPEN FILE FOR SIMULTANEOUS UPDATING
; [431]INIT THE CMPT. JSYS ARG BLOCK
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: ; [431]ENTRY POINT FOR ISAM.IDA FILES
PUSHJ PP,OPNLID ; [431] NO, GET VID...
OCPTNW: ;[570] ENTRY POINT FOR THAWED ACCESS FOR READ ONLY
SETZM CP.BK1 ; [431] AC1 GTJFN BITS
;BUILD A TOPS20 FILE-DESCRIPTOR STRING - AC2 GTJFN BITS
;FIRST JUST MOVE THE DEVICE NAME
MOVE AC1,[FID.BK,,FID.BK+1] ; CLEAR ALL STUFF
SETZM FID.BK
BLT AC1,FID.BK+14
MOVE AC1,[TMP.BK,,TMP.BK+1]
SETZM TMP.BK
BLT AC1,TMP.BK+14
MOVE AC5,TMP.PT ; GET POINTER TO TEMP FILE-DESCRIPTOR
MOVEM AC5,CP.BK2 ; INIT COMPT. ARG BLOCK
MOVE AC0,UOBLK.+1 ; GET THE DEVICE NAME
MOVEM AC0,CP.BK3 ; SET UP FOR COMPT. FUNCT 3--MAYBE
;CONVERT PPN TO <DIRECTORY>
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 AC1,(AC1) ; GET PPN FROM ADR
MOVEM AC1,CP.BK1 ; PPN TO THE ARG-BLOCK
MOVEI AC0,CMP.3 ; FUNCTION 3
MOVEM AC0,CP.BLK ;
MOVE AC0,[4,,CP.BLK] ; SETUP FOR COMPT.
COMPT. AC0, ; MOVE DIR # TO STRING
POPJ PP, ;
;SETUP THE CP.BK? ARGUMENT BLOCK FOR COMPT. UUO
OCPT4: MOVE AC5,TMP.PT ; GET STRING PTR BACK
MOVEI AC1,7 ; CHECK FOR STR RETURNED
OCPT1: ILDB C,AC5 ; VER 1B RETURNED ONLY THE DIRECTORY
; VER 2 RETURNS STR:<DIR>
JUMPE C,OCPT1X ; NO COMPT. DONE, GET DEV NAME
CAIN C,":" ; IT IS ALSO POSSIBLE THAT WHEN
JRST OCPT2A ; HERE WE DID NOTHING AND NOW
SOJG AC1,OCPT1 ; NEED TO INSERT DEVICE NAME FOR OPENF.
OCPT1X: MOVE AC0,[POINT 6,UOBLK.+1] ; WE DIDN'T DO COMPT. OR IT WAS A VER 1B
MOVEI AC1,6 ; SO WE MUST NOW PUT IN STR:
MOVE AC5,FID.PT ; GET REAL STRING PTR
OCPT1A: ILDB C,AC0
JUMPE C,OCPT2 ; GO SEE IF <DIRECTORY> IS NEEDED
ADDI C,40 ; PA1050 WANTS IT IN ASCII
IDPB C,AC5
SOJG AC1,OCPT1A
OCPT2: MOVEI C,":"
IDPB C,AC5
HRRZ AC1,F.RPPN(I16) ; DID USER SUPPLY A PPN?
JUMPE AC1,OCPTV2 ; NO, WE'RE FINALLY DONE
SKIPN @AC1 ; HE GAVE ONE, BUT IS IT REALLY 0
JRST OCPTV2 ; IT WAS 0, SO WE'RE DONE
MOVEI C,"<" ; MOVE IT FROM TEMP STRING TO
IDPB C,AC5 ; REAL STRING
MOVE AC0,TMP.PT
OCPT1B: ILDB C,AC0
JUMPE C,OCPT1C
IDPB C,AC5
JRST OCPT1B
OCPT1C: MOVEI C,">"
IDPB C,AC5
JRST OCPTV2 ; WE NOW HAVE A COMPLETE STRING OF THE FORM
; STR:<DIRECTORY>
OCPT2A: MOVE AC5,FID.PT ; VER 2 SUPPLIED THE <DIR>
MOVE AC1,TMP.PT ; SO WE NEED TO MOVE IT TO THE
MOVEI AC0,^D90 ; REAL STRING AREA AND GET AC5 CORRECT
OCPT2B: ILDB C,AC1 ; MOVE FROM TMP.BK TO FID.BK
JUMPE C,OCPTV2
IDPB C,AC5
SOJG AC0,OCPT2B
OCPTV2:
MOVX AC0,GJ%OLD+GJ%SHT ; SPECIFY THE SHORT FORM OF
MOVEM AC0,CP.BK1 ; [431] GTJFN JSYS
MOVE AC0,FID.PT ; [431] GET POINTER TO FILE DESCRIPTOR STRING
MOVEM AC0,CP.BK2 ; [431] FOR OPENF ARGUMENT
; [431]MOVE VALUE OF ID TO F-D STRING
TLNE FLG,IDXFIL ; [431] SKIP IF NOT ISAM FILE
TLNE FLG1,FOPIDX ; [431] SKIP IF ISAM .IDA FILE
SKIPA AC4,F.WVID(I16) ; [431] BYTE-PTR TO VALUE OF ID
MOVE AC4,[POINT 6,DFILNM(I12)]; [431] .IDA - SO VALUE-ID IS HERE
MOVEI AC0,11 ; [431] MAX OF 11 CHARS
OCPT5: ILDB C,AC4 ; [431] GET A CHAR
TLNN AC4,600 ; [431] IS VID IN EBCDIC?
LDB C,PTR.97## ; [616] [431] YES - CONVERT IT TO ASCII
TLNN AC4,100 ; [431] HOW ABOUT SIXBIT?
ADDI C,40 ; [431] YES, CONVERT IT TO ASCII
CAIE C," " ; [431] SPACES ARE IGNORED IN FILENAME
IDPB C,AC5 ; [431] STUFF IT AWAY
CAIE AC0,4 ; [431] IS IT TIME FOR A "."?
SOJN AC0,OCPT5 ; [431] NO - LOOP TILL DONE
JUMPE AC0,OCPT6 ; [431] JUMP IF DONE
MOVEI C,"." ; [431] TERMINATE THE FILENAME
IDPB C,AC5 ; [431]
SOJN OCPT5 ; [431] BACK FOR THE EXTENSION
OCPT6: SETZB C,AC0 ; [431] A NULL
IDPB C,AC5 ; [431] TERMINATE THE STRING
; [431]INIT AC2 OPENF BITS
TLNE FLG,DDMASC ; [431] DEVICE DATA MODE ASCII?
TLO AC0,(7B5) ; [431] YES
TLNE FLG,DDMSIX ; [431] SIXBIT?
TLO AC0,(6B5) ; [431] YES
TLNE FLG,DDMBIN ; [431] BINARY?
TLO AC0,(44B5) ; [431] YES
TLNN FLG,DDMEBC ; [431] EBCDIC?
JRST OCPT10 ; [431] NO
TLO AC0,(10B5) ; [431] ASSUME DEVICE IS A MAG-TAPE
TXNN AC13,DV.MTA ; [431] DEVICE A MTA?
TLO AC0,(11B5) ; [431] NO, ITSA DSK
OCPT10: TLNE FLG,IOFIL!RANFIL!IDXFIL ; [622] [431] RANDOM,INDEXED OR IO FILES
TLO AC0,(17B9) ; [431] ARE DUMP MODE
TLNE FLG,RANFIL!IDXFIL!OPNIN ; [622] [431] OPEN FOR INPUT?
TRO AC0,OF%RD ; [431] YES
TLNE FLG,OPNOUT ; [431] OPEN FOR OUTPUT?
TRO AC0,OF%WR ; [431] YES
IFE TOPS2X,<
TRO AC0,OF%THW ; [431] THAWED I.E. SIMULTANEOUS UPDATE
>
IFN TOPS2X,<
SKIPN F.WSMU(I16) ;[667] SIMULTANEOUS UPDATE?
TRZA AC0,OF%THW ;[667] NO, CLEAR THAWED BIT
TROA AC0,OF%THW ;[667] [431] THAWED I.E. SIMULTANEOUS UPDATE
TXO AC0,OF%RDU ;[667] TURN ON READ UNRESTRICTED ALSO
>
MOVEM AC0,CP.BK3 ; [431] INIT AC2 OPENF BITS
; [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
MOVEM AC0,CP.BK4 ; [431] OPEN MODE
; [431]LOCATE THE BUFFER HEADERS AND EXTENDED LOOKUP BLOCK
MOVEI AC0,D.IBH(I16) ; [431]
MOVEM AC0,CP.BK5 ; [431] INPUT BUFFER HEADER
MOVEI AC0,D.OBH(I16) ; [431]
MOVEM AC0,CP.BK6 ; [431] OUTPUT BUFFER HEADER
MOVEI AC0,ARGBK. ; [431]
MOVEM AC0,CP.BK7 ; [431] ADR OF EXTENDED LOOKUP BLOCK
; [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
MOVSM AC1,CP.BLK ; [431] ARG ,, FUNCTION
MOVE AC1,[10,,CP.BLK] ; [431] COUNT,,ADR FOR ARG-BLOCK
COMPT. AC1, ; [431] OPEN FILE FOR SIMULTANEOUS UPDATE
POPJ PP, ; [431] ERROR RETURN
IFN ISAM,<TLZ FLG1,FOPIDX> ; [431] CLEAR FLAG
JRST RET.2 ; [431] NORMAL RETURN
OCPER: SETZM FS.IF ; CLEAR .IDA FILE FLAG
IFN ISAM,<
OCPERI: MOVE AC0,[E.MCPT+E.FIDX] ; MAKE AN ERROR NUMBER
TLZN FLG1,FOPIDX ; IDX OR IDA?
MOVE AC0,[E.MCPT+E.FIDA] ; IDA!
TLNN FLG,IDXFIL ; SKIP IF AN ISAM FILE
>; END IFN ISAM
MOVE 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 NON DIRECTORY DEVICE. ***OPNBBF***
OPNRLB: TXNN AC13,DV.LPT!DV.TTY!DV.PTR!DV.PTP!DV.CDR ;[575]SKIP IF DEVICE IS ONE OF THESE
TLNN FLG1,NONSTD+STNDRD ;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,< ;[561]
TXNN AC13,DV.MTA ;[561] SKIP IF MTA, ENTER DONE AT OPNC4A
> ;[561]
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:
IFN ANS68,< ; ONLY IN ANS68 COBOL
MOVEI AC1,1 ;2 WORD CALL,
PUSHJ PP,USEPRO ;TO GET THE USE PRO. ADDRESS
>;END IFN ANS68
TXNN AC13,DV.LPT!DV.PTR!DV.PTP!DV.TTY ;NO LABELS - NO CHECKS
TLNN FLG1,STNDRD ;SKIP IF LABELS ARE STANDARD
JRST OPNABF ;AFTER BEG FILE
TLNE FLG,OPNIN ;SKIP IF NOT INPUT / IO
JRST OPNCSL ;STANDARD LABEL CHECK
PUSHJ PP,OPNCAL ;CREATE A LABEL
;DO AFTER BEGINNING FILE LABEL PROCEDURE
;AND WRITE OUT THE LABEL. ***OPNENR***
OPNABF:
IFN ANS68,<
MOVEI AC1,2 ;TWO WORD CALL
PUSHJ PP,USEPRO ;TO GET USE PRO. ADR.
>;END IFN ANS68
TLNN FLG,OPNOUT ;OUTPUT SKIPS
JRST OPNDVC
TXNE AC13,DV.DIR ;SKIP IF NOT DIR. DEV.
JRST OPNENR
TXNN AC13,DV.LPT!DV.PTP!DV.PTR!DV.TTY!DV.DIR ;SKIP IF LPT,TTY,PTR,PTP,OR DTA,DSK.
TLNN FLG1,NONSTD+STNDRD ;SKIP IF ANY LABELS
JRST OPNDVC ;NO LABELS
PUSHJ PP,RECBUF ;MOVE THE LABEL INTO THE BUFFER
JUMPGE FLG,OPNAB1 ;JUMP IF DEVICE IS NOT ASCII
PUSHJ PP,WRTCR ;
PUSHJ PP,WRTLF ;
OPNAB1: 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)
TXNN AC16,OPN%EX ; APPEND MODE
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: MOVE AC13,UOBLK.+1
DEVCHR AC13, ;THE FINAL DEVCHR
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
OPNDV1: MOVEM AC13,D.DC(I16) ;[330]
MOVEM FLG,F.WFLG(I16) ;UPDATE THE FLAGS
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
TLNE FLG1,STNDRD!NONSTD ;SKIP IF LABELS ARE OMITTED
PUSHJ PP,ZROREC ;CLEAR THE RECORD AREA I.E.LABEL
PUSHJ PP,CLRSTS ;[601] CLEAR FILE STATUS WORD
IFN ANS74,<
TLNN FLG,IDXFIL!RANFIL!OPNIN ;[622]
TLNN FLG,OPNOUT ;TEST FOR SEQ. OUTPUT
JRST OPNDV3 ;NO
SKIPN F.LCP(I16) ;LINAGE STUFF?
JRST OPNDV3 ;NO
HLRZ AC6,F.LAT(I16) ;LINES AT TOP?
JUMPE AC6,OPNDV3 ;ZERO
PUSHJ PP,WRTCR ;THERE ARE SOME
PUSHJ PP,WRTLF
SOJG AC6,.-2 ;LOOP
OPNDV3:>;END IFN ANS74
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:
IFN ANS74,<
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
TLNN FLG1,STNDRD+NONSTD ;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: >; END IFN ANS74
IFN LSTATS,<
LDB AC1,DTCN. ;GET CHAN #
MOVE AC5,AC1 ;SAVE IN AC5
PUSHJ PP,MRDMP ;WRITE OUT ANY EXISTING BUCKETS
MOVE AC0,MROPTT(AC5) ;GET BASE ADDR OF BKT BLK
MOVE AC1,AC0 ;SAVE IN AC1
ADDI AC0,MB.BAS ;ADD OFFSET TO HEADER START
HRLI AC0,-1(AC16) ;AC0= FILTAB-1,,BKT BLK
BLT AC0,MB.FTB(AC1) ;BLT FILTAB BLK TO BUCKET AREA
HRRI AC0,MB.VID(AC1) ;ADDR "VALUE OF ID" IN BKT BLK
HRL AC0,F.WVID(I16) ;ADDR OF "VAL OF ID"
BLT AC0,MB.FG1-1(AC1) ;BLT TO BUCKET BLOCK
HLL AC5,FLG1 ;GET FLG1 FLAGS
MOVEM AC5,MB.FG1(AC1) ;SAVE FLG1 AND CHAN #
HLLM AC16,MB.OCF(AC1) ;SAVE AC16 OPEN FLAG BITS
MOVEI AC1,MB.OTM(AC1) ;GET ADDR OPEN TIME BUCKET
MOVEM AC1,MRTMB. ;SAVE FOR TIMING
SETZM (AC1) ;CLEAR OPEN TIME BUCKET
SKIPE F.WSMU(I16) ;SKIP TIMING STOP IF SMU
JRST OPMRXX ;SMU SKIP
MRTME. (AC1) ;END TIMING
OPMRXX:>;END IFN LSTATS
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
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: HRR AC0,STDLB. ;
MOVE AC1,STDLB.+1 ;
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 OPNCR1 ;MATCH
LDB AC2,F.BPMT ;
JUMPN AC2,OPNCR1 ;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
OPNCR1:
JRST OPNABF
;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,TODAY. ;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 ' ;
MOVEM AC1,STDLB.+4 ;REEL NUMBER AND
MOVEM AC2,STDLB.+5 ;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
IFN ANS74,<
; IN 74 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
OMTA01: >;END IFN ANS74
; NOW SET DENSITY AND HARDWARE DATA MODE
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
TLNE FLG1,NONSTD!STNDRD ; 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
; 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: MOVE AC0,[E.MTAP+^D46] ; 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: MOVE AC0,[E.MTAP+^D45] ; 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,^D47 ; 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: MOVE AC0,[E.MTAP+^D48] ;ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE?
JRST RCHAN ; YES
OUTSTR [ASCIZ /
?TAPOP. failed - unable to get-set label type-information ./]
JRST OMTA99
VSWERR: MOVE AC0,[E.MTAP+^D56] ;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
IFN ANS74,<
;HERE IF READ BACKWARDS NOT SUPPORTED ON SPECIFIED MTA
OMTA97: MOVEI AC0,^D57 ; 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.
TLNN FLG1,NONSTD!STNDRD ; LABELS OMITTED?
MOVEI AC3,1 ; YES, 1 EOF/FILE.
MOVX AC5,DB.HF ;"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
TLNN AC16,100 ;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,^D52 ; 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?
TDNA ; 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]
SKIPA
OPNFW2: OUTSTR [ASCIZ /$ Unexpected EOT marker/] ;[277]
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,DB.HF ;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
IFN ISAM,<
TLNE FLG,IDXFIL ;ISAM ?
SKIPA AC5,[POINT 6,DFILNM(I12)]
>
MOVE AC5,F.WVID(I16) ;BYTE POINTER TO VALUE OF ID
JUMPE AC5,[HRROI C,.GTPRG ;MONITOR TABLE FOR PROGRAM NAME
GETTAB C,
MOVE C,RN.NAM ;USE PROGRAM NAME INSTEAD
MOVEM C,UEBLK. ;FOR ENTER
SETZM ULBLK. ;0 FOR LOOKUP
JRST OPNEI2]
PUSHJ PP,OPNVID ;[447]
OPNEI2: 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
IFN SIRUS,<
MOVSI AC5,015000 ; [403] SET PROTECTION CODE TO ALLOW
MOVEM AC5,UEBLK.+2 ; [403] SIRUS PROJ USERS TO WRITE
>
IFE SIRUS,<
SETZM UEBLK.+2 ;CLEAR PROTECTION AND DATE
>
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
IFN ISAM,<
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
TLNN FLG1,NONSTD!STNDRD
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
TLNE FLG1,NONSTD ;
HLRZ AC0,F.LNLS(I16) ;NON-STD-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
SETZ AC2, ; INIT AC2
TLNE FLG1,STNDRD ; STANDARD LABELS?
MOVEI AC2,^D80 ; YES
TLNE FLG1,NONSTD ; NON-STANDARD LABELS?
HLRZ AC2,F.LNLS(I16) ; 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 CRARS 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***
IFN ISAM,<
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: MOVE AC0,[E.MOPE+E.FIDA];ERROR NUMBER
SETZM FS.IF ;IDA FILE
JRST OERRI1 ;
;OPEN FAILED
OERRIF: MOVE AC0,[E.MOPE+E.FIDX];ERROR NUMBER
TLNN FLG,IDXFIL ;IDX FILE?
MOVE 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: MOVE AC0,[E.MREN+E.FIDX];MAKE AN ERROR NUMBER
JRST OEERR1 ;
;RENAME FAILED
ORERR: SETZM FS.IF ;IDA FILE
MOVE AC0,[E.MREN+E.FIDA];ERROR NUMBER
TLNN FLG,IDXFIL ;IDX FILE?
MOVE AC0,[E.MREN] ;NO, ERROR NUMBER
JRST OEERR1 ;
;ENTER OF "IDX" FILE FAILED
OEERRI: MOVE AC0,[E.MENT+E.FIDX];ERROR NUMBER
JRST OEERR1 ;
;ENTER FAILED
OEERR: MOVEI AC0,^D30 ;GET FILE-STATUS CODE = PERM. ERROR
MOVEM AC0,FS.FS ;SET IT UP
SETZM FS.IF ;IDA FILE
MOVE AC0,[E.MENT+E.FIDA];ERROR NUMBER
TLNN FLG,IDXFIL ;IDX FILE?
MOVE 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: MOVE AC0,[E.MLOO+E.FIDX];ERROR NUMBER
JRST OLERR1 ;
;LOOKUP FAILED
OLERR: SETZM FS.IF ;IDA FILE
MOVE AC0,[E.MLOO+E.FIDA];ERROR NUMBER
TLNN FLG,IDXFIL ;IDX FILE?
MOVE 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,^D30 ;YES
MOVEM AC1,FS.FS ;LOAD FILE-STATUS
JRST IGCVR ;FINISH UP
;RELEASE THE IO CHANNEL AND NOTE THAT IT'S FREE
RCHAN:
IFN ISAM<
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
;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,^D10 ;ERROR NUMBER
JRST OXITER ;ONLY CLOSED FILES MAY BE OPENED
;FILE ALREADY LOCKED
OPNFAL: MOVEI AC0,^D11 ;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,^D13 ;ERROR NUMBER
JRST OXITER ;COMPLAIN
;IF CHECKPOINT MODE IS REQUIRED SET BIT IN OPEN BLOCK
IFE TOPS20,<
OPNCKP: SKIPN M7.00 ;IS IT 7.00 OR LATER?
POPJ PP, ;NO
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,
>
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
XCT UOUT. ;DO THE OUTPUT
PUSHJ PP,CKFOD ;NORMAL RETURN, SEE IF CHECKPOINT REQUIRED
WRTWAI: XCT UWAIT. ;FOR ALL THE ERRORS
XCT UGETS. ;
TXNE AC2,IO.ERR ;ERRORS?
JRST WRTERR ;THERE ARE ERRORS.
WRTFIN: MOVE AC13,D.DC(I16) ; GET DEVICE CHARACTERISTICS
TXNE AC13,DV.MTA ;MTA?
TXNN AC2,IO.EOT ;EOT?
JRST WRTXIT ;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,ENDSTS ;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.
TXZ AC2,IO.ERR!IO.EOF ;OTHER.
XCT USETS. ;SET STATUS
POPJ PP, ;RETURN
;[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/]
TXNE AC2,IO.DTE
OUTSTR [ASCIZ/ data error/]
TXNN AC2,IO.BKT
POPJ PP,
TXNE AC13,DV.DSK ;DSK?
OUTSTR [ASCIZ / quota exceeded, file structure or rib full/]
IFE TOPS20,<
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
IFN ANS74,<
MOVE 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:
IFN ANS68,<
MOVE AC0,[E.MINP] ;INPUT ERROR
>
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
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 OSHOOT ;[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:
IFN ISAM<
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: MOVEI AC4,11 ;9 CHARACTERS
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 9 TIMES
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.
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./] ;11
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
;LOOKUP OR ENTER ERROR MESSAGES. ***KILL OR OPNENR***
LUPERR: 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
IFN ISAM,<
TLNE FLG1,EIX ;IF INDEX FOR ISAM FILE
JRST OPNI00 ; EXIT HERE
>
JRST OPNENR ;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 extersion.\]
[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
PURGE.: TLZ AC16,(Z 17,)
TLO AC16,(Z 1,) ;MAKE PURGE BE A CLOSE VERB
SETOM PRGFLG ;REMEMBER TO RENAME TO ZERO
;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.
C.CLOS:
IFN LSTATS,<
MRTMS. (AC1) ;START METER TIMING
LDB AC1,DTCN. ;GET CHANNEL NUMBER
MOVE AC1,MROPTT(AC1) ;GET FILE BLOCK ADDRESS
HLRM AC16,MB.OCF(AC1) ;SAV CLOSE AC16 FLAG BITS
>;END IFN LSTATS
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
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: MOVE AC0,[E.VCLO+^D20];ERROR NUMBER
TLNN FLG,OPNIN+OPNOUT
SKIPA AC2,[BYTE(5)10,31,20,37,33]
SKIPA AC13,D.DC(I16) ;PICK UP DEVICE CHARACTERISTICS
JRST OXITER ;FILE WAS NOT OPEN.
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
LDB AC5,F.BPMT ;FILE POSITION ON TAPE
TXNN AC16,CLS%CR ;SKIP IF CLOSE REEL
JRST [TXO AC16,CLS%EF ;%CLOSE FILE
JRST CLOS00] ;GO DO IT
TXNN AC13,DV.MTA ;MTA?
POPJ PP, ; NO, IGNORE & CONTINUE
TXO AC16,CLS%EV ;% CLOSE REEL
JUMPN AC5,CLOSF5 ;CLOSE "REEL" A MULTI-FILE-REEL - AN ERROR
CLOS02: TXNE AC16,CLS%EV ;CLOSE REEL?
TXNE AC13,DV.MTA ;CLOSE REEL AND NOT MTA?
JRST CLOS00 ;NO
MOVEI AC0,^D33 ;ERROR NUMBER
PUSHJ PP,IGCVR ;IGNORE ERROR?
JRST CLOS00 ;YES
OUTSTR [ASCIZ /$ CLOSE REEL is legal only for MAG-tape.
/]
MOVE AC2,[BYTE(5) 10,31,20,37,4,14]
JRST MSOUT. ;NON-FATAL CONTINUE WITH A POPJ
CLOS00: PUSHJ PP,SETCN. ;DISTRIBUTE THE CHAN NUMBER
HLRZ AC12,D.BL(I16) ;BUFFER LOCATION
IFN ISAM,<
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 CLOSE0 ;
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
CLOSE0: 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 ;MTA?
JRST CLOSE2 ; YES, SKIP FUNNY EXTRA 'CR'
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.
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, DO BEFORE ENDING FILE/REEL USE PROCEEDURE,
;AND CHECK FOR "EOF/V" LABEL TYPE.
CLOSE3: 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 CLOSE4 ;[341] NO
TLNE FLG1,NONSTD!STNDRD ;[341] IF LABELLED
XCT MADVF. ;[341] SKIP OVER EOF AFTER LABEL REC.
CLOSE4:
IFN ANS68,<
MOVEI AC1,3 ;
PUSHJ PP,USEPRO ;BEFORE ENDING FILE/REEL
>;END IFN ANS68
TLNN FLG,OPNIN ;SKIP IF INPUT
JRST CLOSE6 ;JUMP IF OUTPUT
TLNE FLG1,STNDRD ;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,DO AFTER ENDING FILE/REEL USE PROCEEDURE,
;WRITE OUT THE LABEL AND LOCK THE FILE.
CLOSE6: PUSHJ PP,CLSCAL ;CREATE STD MTA ENDING LABEL
CLOSE7:
IFN ANS68,<
MOVEI AC1,4 ;
PUSHJ PP,USEPRO ;AFTER ENDING FILE/REEL
>;END IFN ANS68
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
PUSHJ PP,OPNRWD ;REWIND UUO
IFN ANS74,<
TXNE AC16,CLS%UN ;UNLOAD?
XCT MREWU. ;YES
>;END IFN ANS74
CLOSF2: MOVX AC0,DB.HF
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
TLNE FLG1,NONSTD!STNDRD ;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: ;[336]
IFN ISAM,<
TLNN FLG,IDXFIL ;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. ;DELET 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,DB.HF ;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
HRRZ AC0,D.RFLG(I16) ; GET MORE FLAGS
TRZ AC0,RF1CLR ; CLEAR SOME
HRRM AC0,D.RFLG(I16) ; AND RESET THE WORD
XCT URELE. ;RELEASE THE DEVICE**************
PUSHJ PP,CLRSTS ;CLEAR FILE STATUS WORD
IFN LSTATS,<
PUSHJ PP,MTRCLS ;END CLOSE METERING
>
JRST FRECHN ;EXIT TO THE ***"ACP"***
IFN LSTATS,<
MTRCLS: LDB AC2,DTCN. ;GET CHAN NUMBER
MOVE AC2,MROPTT(AC2) ;GET METER BLOCK BASE ADDRESS
;NO. OF INPUTS & OUTPUTS EXECUTED
MOVE AC1,D.IE(I16) ;GET NO. OF INPUTS
MOVEM AC1,MB.NIN(AC2) ;PUT # INPUTS INTO FILE BLOCK
MOVE AC1,D.OE(I16) ;GET NO. OF OUTPUTS
MOVEM AC1,MB.NOU(AC2) ;PUT # OUTPUTS INTO FILE BLOCK
MOVEI AC2,MB.CTM(AC2) ;GET ADDRESS OF CLOSE BUCKET
MOVEM AC2,MRTMB. ;SAVE FOR TIMING
SETZM (AC2) ;CLEAR CLOSE TIME BUCKET
MRTME. (AC2) ;END METER TIMING
;CLEAR ENTRIES IN FILE/BLOCK TABLE (SORT OF "FLUSHING THE CACHE")
JRST CLRFBT ;RETURN
>;END IFN LSTATS
CLOSF5: MOVE AC0,[E.FIDX+^D21];ERROR NUMBER
TLNN FLG,IDXFIL ;SKIP IF AN ISAM FILE
MOVEI AC0,^D21 ;ERROR NUMBER
PUSHJ PP,IGCVR ;IGNORE ERROR?
JRST CLOS02 ;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:
TLNN FLG,RRUNER ;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
TDNA ; 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: LDB AC2,DTCN. ;GET CHANNEL NUMBER
PUSHJ PP,GETJFN ; GET JFN IN AC1
JRST [OUTSTR [ASCIZ/Reel change get JFN ./] ;ERROR, ISSUE MESSAGE
JRST OCPERR ] ;MORE MESS AND KILL
;NOW MUST DO OPENF TO MAKE SURE THE JFN IS OPEN
MOVE AC3,AC1 ;SAVE JFN IN CASE OF OPENF ERROR
MOVE AC2,[440000,,200000] ;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
TLO 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
IFN LSTATS,<
PUSHJ PP,MTRCLS ;END CLOSE TIMING
>
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
MRTMS. (AC1) ;START OPEN TIMING
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
TLNN FLG1,NONSTD+STNDRD ;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,^D32 ;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
IFN ISAM,<
;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 CLOSE4
>
;CREATE A LABEL OR ZERO IT. ***@POPJ***
CLSCAL: TXNE AC13,DV.MTA ;SKIP IF DEVICE IS NOT A MTA
TLNN FLG1,STNDRD ;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
JRST CLSWL1 ;[576] SKIP BUFFER SAVES,DELETE FOLLOWS
IFE TOPS20,<
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
CLSWLX:>;[576] END IFE TOPS20
XCT UCLOS. ;[576] DUMP ALL THE BUFFERS
CLSWL1: PUSHJ PP,WRTWAI ;[576] WAIT FOR ERROR CHECKING
IFN TOPS20,<
SKIPN F.WSMU(I16) ;[576] [571] ANY RETAINED RECORDS?
JRST CLSWLA ;[576] SKIP AHEAD IF NOT SMU
PUSHJ PP,CLWSMU ;[576] FREE RETAINED BLOCKS
>;[576] END IFN TOPS20
CLSWLA: TXNE AC13,DV.MTA ;[573] SKIP NOT A MAGTAPE
TLNN FLG1,NONSTD+STNDRD ;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 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.: MRTMS. (AC1) ;START METER TIMING HERE
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: MRTMS. (AC1) ;START METER TIMING HERE
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. ;[QAR] IF THIS IS A REPORT WRITER CALL
JRST WRITE2 ;[QAR] 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:
IFN LSTATS,<
MOVE AC1,AC3 ;GET RECORD LENGTH
PUSHJ PP,BUCREC ;SET AC2 TO REC BUCKET
L.METR (MB.WRT(AC2),I16) ;CNT WRT BUCKET
>;END IFN LSTATS
TLNN FLG,OPNOUT ;SKIP IF OPEN FOR OUTPUT
JRST ERROPN ;ERROR MESSAGE
IFN ISAM,<
TLNE FLG,IDXFIL ;
JRST IWRITE ;WRITE AN INDEX-FILE
>
IFN ANS68,<
TLNE FLG,RANFIL+IOFIL ;[622] SKIP IF NOT RANDOM OR I/O
JRST RANDOM ;RANDOM AND IO EXIT HERE
>
IFN ANS74,< ;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
SKIPN AC0 ;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 ;NOT-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
HRRZ AC4,D.RFLG(I16) ; NO,GET AFT-ADV ASCII FLAG
TRO AC4,AFTADV ; SET IT
HRRM AC4,D.RFLG(I16) ; RESET 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
IFN ANS74,<
TRNA ;NORMAL RETURN
AOS (PP) ;COPY END OF PAGE SKIP RETURN
>
JRST WRTRCB ; CONT
WRTRCA:
IFN ANS74,<
JUMPGE FLG,WRTRCB ; JUMP THIS IF NOT ASCII
; 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?
TDNA ; NO,THEN WRITE CR-LF
JRST WRTRCB ; YES,NO CRLF
PUSHJ PP,WRTCR ; ELSE, "CR" AND
PUSHJ PP,WRTLF ; "LF"
>
WRTRCB:
JUMPE AC3,WRTZRE ;TRYING TO WRITE A NULL REC?
; SUPPRESS TRAILING BLANKS FOR ASCII OUTPUT FILES
IFN SUPP, <
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
REPEAT 0,< ;[CCS-1] REMOVE THIS CODE
WRTRE3: PUSHJ PP,WRTADV ;WADV.
IFN ANS74,<
TRNA ;NORMAL RETURN
AOS (PP) ;COPY END OF PAGE SKIP RETURN
>
JRST WRTRE6 ;
; WRITE SIXBIT FILES HERE-NO TRAILING BLANK SUPPRESSION
WRTSIX: ILDB C,AC6 ;CHAR FROM THE RECORD AREA
XCT AC10 ;CONVERT IF NECESSARY
IDPB C,D.OBB(I16) ;CHAR TO THE BUFFER
SOSG D.OBC(I16) ;SKIP IF YOU CAN
PUSHJ PP,WRTBUF ;BUFFER FULL, WRITE IT OUT
SOJG AC3,WRTSIX ;LOOP TILL A COMPLETE RECORD IS PASSED
>;END OF REPEAT 0
> ; END OF IFN SUPP- BLANK SUPPRESS CODE
;[CCS-1] Include this code even if suppressing blanks
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 WTRE2C ; ELSE DO CR-LF
PUSHJ PP,WRTADV ;WADV.
IFN ANS74,<
TRNA ;NORMAL RETURN
AOS (PP) ;COPY END-OF-PAGE SKIP RETURN
>;END IFN ANS74
JRST WRTRE6 ; CONT
; PADLAB ROUTINE TO SAV 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
WTRE2C:
IFN ANS68,<
; IF STD-ASCII AND MTA, THEN NO CR-LF
HRRZ AC4,D.RFLG(I16) ; GET STANDARD ASCII FLAG
TRZ AC4,AFTADV ; CLEAR 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?
TDNA ; NO,THEN WRITE CR-LF
JRST WRTRE6 ; YES,NO CRLF
PUSHJ PP,WRTCR ; WRITE "CR"
PUSHJ PP,WRTLF ; WRITE "LF"
>;END IFN ANS68
JRST WRTRE6 ;
;[CCS-1] Delete ">" for END IFE SUPP
;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:
IFN ANS74,<
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:
IFN LSTATS,<
TXNE AC16,V%STRT ;IS THIS START?
JRST WRTRWT ;YES,SO SKIP THIS MESS
TXNN AC16,V%READ ;SKIP IF READ
JRST WRTRWT ;WRITE JUMPS
MOVE AC1,D.CLRR(I16) ;GET CHAR LENGTH OF REC READ
PUSHJ PP,BUCREC ;SET AC2 TO REC BUCKET OFFSET
TXNE AC16,V%RNXT ;IS IT READ NEXT ?
JRST WRTRNX ;YES, JUMP
L.METR (MB.RDD(AC2),I16) ;NO, CNT BUCKET FOR READ
JRST WRTRWT ;FINISH
WRTRNX: L.METR (MB.RNX(AC2),I16) ; METER READ NEXT BUCKET
WRTRWT: MRTME. (AC1) ;END TIMING, UPDATE TIME BUCKET
;THIS ENDS TIMING FOR READ,READ NEXT,
;WRITE AND START
>;END IFN LSTATS
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
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:
IFN ANS68,<
TXNN AC16,V%READ ;SKIP IF READ
>
IFN ANS74,<
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,1440 ;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
HLRZ AC1,F.LNLS(I16) ;NONSTD LABEL SIZE IN CHARS
LDB AC2,[POINT 2,FLG,14] ; GET CORE DATA MODE
HRRZ AC2,RBPTBL(AC2) ; GET CHARS PER WORD
IDIV AC1,AC2 ;CONVERT TO WORDS/LABEL
SKIPN AC1+1 ;
SUBI AC1,1 ;ROUND DOWN
HLLZ FLG1,D.F1(I16) ;FLAGS
TLNN FLG1,NONSTD ;SKIP IF NONSTD LABELS
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 @ OPNDV1
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
TLNN FLG,RRUNRC ;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
IFN LSTATS,<
JFFO AC2,.+1 ;AC3=# ZEROS TO LEFT OF AC2'S LEFT 1
MOVEI AC1,RRBITS ;GET NUMBER OF INTERESTING BITS ON LEFT
SUB AC1,AC3 ;CALC BUCKET PAIR POSITION
CAILE AC1,RR.NUM ;LS= UPPER BOUND?
MOVEI AC1,RR.NUM ;NO, MAKE IT UPPER BOUND
JUMPGE AC1,.+2 ;SKIP IF GTR= ZERO
SETZ AC1, ;MAKE ZERO
MRTMS. (AC3) ;START RERUN TIMING
LSH AC1,1 ;MULTILY BY 2 (COUNTING TIMING BKTS)
L.METR (MB.RRN(AC1),AC16) ;SET RERUN METER POINT
>;END IFN LSTATS
JRST CKRRN2
CKRRN1: SKIPL REDMP. ;SKIP IF A FORCED DUMP
POPJ PP, ; NEITHER DUMP RETURN NOW
CKRRN2: PUSHJ PP,RRDMP ;DUMP
PUSHJ PP,RSAREN ;RESTORE .JBSA, .JBREN
MRTME. (AC1) ;END RERUN METER TIMING
POPJ PP, ; ALL DONE, RETURN
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,^D30 ;PERMANENT ERROR
MOVEM AC0,FS.FS ;LOAD FILE-STATUS
MOVEI AC0,^D35 ;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,^D30 ;PERMANENT ERROR
MOVEM AC0,FS.FS ;LOAD FILE-STATUS
HRRZM AC2,.JBFF ;BACK OUT OF OVERLAY AREA
MOVEI AC0,^D8 ;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: TLNN FLG,DDMBIN ;[343] IF BINNARY LET NXT WRITE/CLOSE OUTPUT 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 SYM-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
IFN ANS74,<
JUMPN C,WAD2 ;GIVE UP IF NOT JUST LINE FEED
SKIPE F.LCP(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
IFN ANS74,<
SKIPN F.LCP(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,F.LCP(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,F.LCP(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,F.LCP(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
IFN ANS74,<
WRTDC3: PUSHJ PP,WRTCR ;CR
MOVEI C,$DC3 ;DC3
JRST WRTCH ;WRITE AND RETURN
>
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,
;SEE IF ZERO LEN RECORD IS LEGAL
WRTZRE: SKIPE NOCR. ;
JRST WRTRE2 ;A WAY TO GET ONLY PAPER-ADVANCING-CHARS
MOVEI AC0,^D23 ;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, ;
ERROPN: AOS (PP) ;REWRITE-WRITE-DELETE
MOVEI AC0,^D22 ;THE "OUTPUT" MESSAGE
TRNA
ERROP1: MOVEI AC0,^D34 ;THE "INPUT" MESS
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"
PUSHJ PP,MSOUT.
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
MOVEI AC0,^D6 ;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]
JRST MSOUT. ;CANNOT DO OUTPUT (OR INPUT)
ERRMRX: POP PP,AC0 ;RESTORE MAX-REC-SIZE
POPJ PP,
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 ;[-74] TURN ON READ NEXT FLAG
READ.: MRTMS. ;START LIBOL METER TIMING
SKIPE F.WSMU(I16) ;ANY RETAINED RECORDS?
PUSHJ PP,SU.RD ; YES
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
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
IFN ISAM,<
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
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: 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
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
;BL JRST READ8 ; ALL DONE IN BUFFER, CONT
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
; INSERTED AT READ6A+9
;BL JUMPL C,READ8 ; END SCAN IF EOR CHAR
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 VLREBC 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: 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
;MOVE THE RECORD INTO THE RECORD AREA
RER7: 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,^D39 ; 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,^D40 ; 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,^D41 ; 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,^D42 ; 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,^D43 ; 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,^D44 ; 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
PUSHJ PP,ENDSTS ;SET FILE STATUS TO 10
JRST RET.2 ;SKIP EXIT
RNULER: SKIPE AC0,D.LBN(I16) ; GET LAST BLK NUMBER,IF THERE IS ONE
CAME AC0,D.CBN(I16) ; SKIP IF LAST BLOCK
JRST RNRNUA ; NO(T) LAST BLOCK,ERROR
SETZM R.WRIT(I12) ; ZERO THE WRITE FLAG
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,ENDSTS ;[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.
TLNN FLG1,STNDRD ;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,440 ;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,^D25 ;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
REAAEE: SETOM FS.IF ;IDX FILE
MOVEI AC0,^D24 ;ERROR NUMBER
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./]
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,^D26 ;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: 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
IFN LSTATS,<
SETZ AC1, ;ASSUME = TEST
TXNE AC16,STA%GT ;IS IT .GT. TEST ?
AOJA AC1,.+3 ;YES,INDICATE AND GO
TXNE AC16,STA%NL ;IS IT .GE. TEST ?
MOVEI AC1,2 ;YES, MARK THIS
LSH AC1,1 ;MULTIPLY BY 2
L.METR (MB.STE(AC1),AC16) ;METER THE START MARKED BY AC1
;START METER TIMING BEGINS IN READ
>;END IFN LSTATS
JRST READ. ;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,NRESTS ; SET REC NOT FOUND (23)
JRST RET.2 ;AND GIVE ERROR RETURN
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 (74)
;CHECK THE FILE-LIMITS, READ IN THE LOGICAL BLOCK, AND
;POINT AT THE RECORD. ***WRTRE7***
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 ;
IFN ANS68,<
PUSHJ PP,FLIMIT ;CHECK ACTUAL KEY VS. FILE LIMITS
>
IFN ANS74,<
PUSHJ PP,SETKEY ;SET AND CHECK RELATIVE KEY
>
; THE FOLLOWING CALCULATES THE DISTANCE BETWEEN RANDOM I/O
;REQUESTS AND INCREMENTS THE APPROPRIATE BUCKET.
IFN LSTATS,<
JUMPE AC4,RDKYDX ;SKIP ALL THIS IF KEY ZERO
MOVE AC1,AC4 ;GET KEY
SUB AC1,D.RP(I16) ;GET DISTANCE FROM CURRENT RECORD
MOVEI AC2,3 ;ASSUME DIST. SMALL POS.
JUMPL AC1,RDKYD0 ;SKIP AHEAD IF NEG DISTANCE
CAIGE AC1,^D100 ;DIST. LS 100?
JRST RDKYD2 ;YES,GO CHECK 0-99 RANGE
CAIL AC1,^D1000 ;DIST. GTR= 1000?
ADDI AC2,1 ;YES,INCREMENT TO GET 5
ADDI AC2,1 ;NO, INCREMENT TO GET 4
JRST RDKYD1 ;GO COUNT BUCKET
RDKYD0: MOVN AC1,AC1 ;MAKE POS
CAIG AC1,^D100 ;DIST FARTHER THAN 100?
SOJA AC2,RDKYD1 ;NO,INDICATE OFFSET 2 AND GO BUCKET
CAILE AC1,^D1000 ;DIST FARTHER THAN 1000?
SUBI AC2,1 ;YES,SUB TO GET 0 OFFSET
SUBI AC2,2 ;NO,SUB TO GET 1 OFFSET
RDKYD1: LDB AC1,DTCN. ;GET CHANNEL NUMBER
ADD AC2,MROPTT(AC1) ;ADD BUCKET BLK ADDR TO OFFSET
AOS MB.KYD(AC2) ;INCREMENT BUCKET
JRST RDKYDX ;FINISHED NOW
RDKYD2: SOJG AC1,RDKYD3 ;JUMP IF GRT THAN 1
AOS AC2,AC1 ;ELSE SET AC2=AC1+1
JRST RDKYD4 ;AND GO INCR BUCKET
RDKYD3: CAIGE AC1,5 ;SKIP IF GTR = 6 (REMBER -1 ABOVE)
SOJA AC2,RDKYD4 ;ELSE SET AC2=2 AND GO BUCKET
CAILE AC1,^D24 ;SKIP IF LS = 25
ADDI AC2,1 ;ELSE SET AC2=4
RDKYD4: LDB AC1,DTCN. ;GET CHANNEL NUMBER
ADD AC2,MROPTT(AC1) ;ADD BUCKET BLK ADDR TO OFFSET
AOS MB.KY2(AC2) ;INCREMENT BUCKET
RDKYDX:>;END IFN LSTATS
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.
IFN ANS74,<
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
IFN ANS74,<
TXNN AC16,V%DLT+V%RWRT ; IS THIS DELETE OR RERIT?
JRST RAND2A ; NO, CONT
LDB AC0,F.BFAM ; GET ACCESS MODE
JUMPN AC0,RANDO2 ; IF NOT SEQ ACCESS SKIP POSITION CHANGE
>
RAND2A: MOVEM AC5,R.BPNR(I12) ;SAVE AS CURRENT RECORD
;HERE TO CHECK THAT NEW RECORD SIZE LE THAN MAX
RANDO2: HRRZ AC2,@AC5 ;RECORD SIZE IN CHARACTERS
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!
IFN ANS68,<
MOVE AC1,F.RACK(I16) ;GET THE
MOVE AC1,(AC1) ; ACTUAL KEY
>
IFN ANS74,<
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?
IFN ANS68,<
JUMPN AC1,RANDO3 ;YES - NEXT RECORD?
>
IFN ANS74,<
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
IFN ANS74,<
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,NRESTS ;[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:
IFN ANS74,<
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
IFN ANS74,<
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:
IFN ANS74,<
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
IFN ANS74,<
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
JRST RAND10
RANDO9: SETOM R.DATA(I12) ;FORCE WRITE LATER
SETOM R.WRIT(I12) ;REMEMBER IT WAS A WRITE
IFN ANS74,<
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
>;END IFN ANS74
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:
IFN ANS74,<
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
SQIO1:
; IF R.DLRW(I12) SET THEN READ BACK "CURRENT" DSK BLK
IFN ANS74,<
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
>;END IFN ANS74
SQIO1A: SKIPN R.WRIT(I12) ;SKIP IF WRITE WAS LAST
IFN ANS68,<
TXNN AC16,V%WRITE!V%WADV ;SKIP IF WRITE AFTER READ
>
IFN ANS74,<
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,ENDSTS ; [601] NO NEXT REC STATUS (10)
IFN ANS74,<
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
IFN ANS74,<
TXNN AC16,V%DLT+V%RWRT ; IS THIS DELETE OR RERIT?
JRST RNERAA ; NO, CONT
LDB AC0,F.BFAM ; GET ACCESS MODE
JUMPN AC0,.+2 ; 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:
IFN ANS74,<
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,^D23 ; READ INVALID KEY
MOVEM AC1,FS.FS ; LOAD FILE-STATUS
JRST RNER40 ; EXIT
;RESTORE THE NULL CHARS IF ANY
RNER06:
IFN ANS74,<
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:
IFN ANS74,<
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: 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
IFN ANS74, JUMPGE FLG1,RNR30A ; JUMP IF FIXED LEN RECORDS
IFN ANS68, JUMPGE FLG1,RNER33 ; JUMP IF FIXED LEN RECORDS
PUSHJ PP,RNDW ; GET RDW INTO AC1
IFN ANS74, JUMPN AC1,RNR30C ; IT WILL BE 0 IF WE ARE APPENDING
IFN ANS68, JUMPN AC1,RNER31 ; IT WILL BE 0 IF WE ARE APPENDING
IFN ANS74,<
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
IFN ANS74,<
;CHECK FOR NULL RECORD ERRORS
RNR30A: MOVE AC1,AC5 ; GET COPY DESTINATION PTR
ADDI AC1,1 ; ADVANCE PTR PAST RDW
ILDB AC1,AC1 ; GET A BYTE
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
>;END IFN ANS74
RNER31:
IFN ANS74,<
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:
IFN ANS74,<
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:
IFN ANS74,<
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
IFN ANS74,<
;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
>;END IFN ANS74
;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***
IFN ANS74,<
WRTNUL: TLNE FLG,RANFIL
TXNN AC16,V%WRITE ;RANDOM WRITE ?
POPJ PP, ; NO,OK- GO BACK
PUSHJ PP,DPLSTS ;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
POP PP,(PP) ; KILL RETURN TO CALL POINT
JRST RET.3 ;BYPASS WRITE PARAMETERS & GIVE ERROR RETURN
>;END IFN ANS74
RANWRZ:
IFN ANS74,<
PUSHJ PP,WRTNUL ; CHECK FOR WRITE ON NULL (NO RETURN ON ERROR)
>
RANWR0:
IFN ANS74,< ;[670]
TXNE AC16,V%DLT ;[670]IF DELETE
JRST .+3 ;[670] SKIP BINARY CHECK
> ;[670]
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:
IFN ANS68,<
TXNN AC16,V%WRITE!V%WADV ;IF IT'S WRITE,
>
IFN ANS74,<
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
IFN ANS74,<
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
IFN ANS74,<
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: PUSHJ PP,RANCR ;[WADV] WRITE CR
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
IFN ANS74,<
TXNE AC16,V%RWRT ; IS THIS RERIT?
JRST RANXI0 ; YES,SKIP CURRENT POSITION RESET
>
EXCH AC5,R.BPNR(I12) ;UPDATE NXT REC PTR
MOVEM AC5,R.BPLR(I12) ;UPDATE LAST REC PTR
JRST RANXI0 ;FINISH AND EXIT
IFN ANS74,<
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
AOJA AC5,RNWR2X ;UPDATE THE RECORD POINTER & SIGNAL ACTIVE DATA
RANDLA: HRRZ AC1,AC5 ; GET ADR OF FIRST REC WORD
SKIPN AC2 ;[670] SKIP IF NOT A NULL RECORD
JRST RNDLER ; NULL! 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: JRST RANDO3 ;[601] EXIT WITH INVALID KEY
>;END IFN ANS74
;MOVE THE RANDOM/IO BUFFER AREA TO THE RECORD AREA. ***RANXIT***
RANREA:
IFN ANS74,<
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
JUMPE AC4,RANDOM ;[300] JUMP IF SEQ
MOVEI AC1,^D23 ; 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
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,ENDSTS ;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:
IFN ANS74,<
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
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
REPEAT 0,< ; THIS PATCH IS NOT WORTH IT
; THERE ARE OTHER PLACES WHERE THE COUNT CAN RUN OUT
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
>
REPEAT 1,< ; THIS IS THE ORIGINAL CODE
RNR13B: ILDB C,AC5 ; GET A CHAR
XCT AC10 ; CONVERT IT
JUMPGE C,RNR13B ; SCAN TO EOR CHAR
>
RANR14:
IFN ANS74,<
TXNN AC16,V%DLT+V%RWRT ; IS THIS DELETE OR RERIT?
JRST RNR14A ; NO, CURRENT POSITION RESET
LDB AC0,F.BFAM ; GET ACCESS MODE
JUMPN AC0,.+2 ; 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:
IFN ANS74,<
TXNN AC16,V%DLT+V%RWRT ; IS THIS DELETE OR RERIT?
JRST RNXITA ; NO, CONT
LDB AC0,F.BFAM ; GET ACCESS MODE
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: 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
SKIPE F.WSMU(I16) ; SIMULTANEOUS UPDATE ?
PUSHJ PP,LRDEQX## ; YES
IFN ANS74,<
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
SKIPN AC1,FS.FS ; NO CHANGE IF NON ZERO
MOVEI AC1,^D10 ; READ INVALID KEY
MOVEM AC1,FS.FS ; LOAD FILE-STATUS
SETOM R.WRIT(I12) ;READ NOT SUCCESSFUL
JRST RANXI2 ;
RANXI8:
IFN ANS74,<
PUSHJ PP, NRESTS ; 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
IFN ANS74,<
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
IFN ANS74,<
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:>;END IFN ANS74
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:
IFN ANS74,<
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
TDNA ; AND SKIP
>
RANI0A:
IFN ANS74,<
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
IFN LSTATS,< ;CALL I/O HISTOGRAM ROUTINE TO RECORD
; THIS BLOCK REFERENCE
IFN ANS74,<
LDB AC5,F.BFAM ;GET ACCESS MODE
JUMPE AC5,RANMRX ;IF SEQ ACCESS SKIP THIS
>
MOVEM AC1,MRBNUM ;BLOCK NUMBER STORED HERE
PUSHJ PP,IOHSTR ;CALL HISTOGRAM ROUTINE
RANMRX:
>;END IFN LSTATS
TLNN AC1,-1 ; [641] IF GREATER THAN 777777
CAILE AC1,-11 ; [641] OR BETWEEN 777770 AND 777777
PUSHJ PP,FUSI ; DO A FILOP. TYPE USETI
XCT USETI. ;*****************
RANI00: HRRM AC12,UIN. ;DUMP MODE IOWD
LDB AC5,F.BBKF ;BLOCKING FACTOR
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
IFN ANS74,<
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
IFN ANS68,<
HRRZ AC4,F.RACK(I16)
MOVE AC4,(AC4) ;GET ACTUAL KEY AGAIN
>
IFN ANS74,<
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,ENDSTS ; [601] YES,SET NO NEXT RECORD
JRST RANIN5 ; [601] GO ON
RANN4A: PUSHJ PP,NRESTS ; [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
TLNN AC1,-1 ; [641] IF GREATER THAN 777777
CAILE AC1,-11 ; [641] OR BETWEEN 777770 AND 777777
PUSHJ PP,FUSO ; DO A FILOP. TYPE USETO
XCT USETO. ;******************
MOVE AC1,D.CBN(I16) ;NEXT BLOCK BECOMES CURRENT BLOCK
HRRM AC12,UOUT. ;DUMP MODE IOWD
JRST WRTOUT ;DO IT
;CHECK ACTUAL KEY AGAINST THE FILE-LIMIT-CLAUSES AND TAKE
;THE INVALID-KEY RETURN IF NOT LEGAL. ***POPJ***
IFN ANS68,<
FLIMIT: MOVE AC1,R.FLMT(I12) ;PICK UP THE IOWD "FLC"
HRRZ AC4,F.RACK(I16)
SKIPN AC4,(AC4) ;ACTUAL KEY
POPJ PP, ;OK IF 0, HE WANTS TO READ SEQ FROM HERE
TRNA
FLIMI1: ADDI AC1,2 ;ACCOUNT FOR TWO LIMIT WORDS
CAMLE AC4,2(AC1) ;SKIP IF ACTKEY LE LARGER LIMIT
JRST .+3
CAML AC4,1(AC1) ;SKIP IF ACTKEY L THE SMALLER LIMIT
POPJ PP, ;OK EXIT
AOBJN AC1,FLIMI1 ;
TXNN AC16,V%READ!V%WRITE!V%WADV ;SKIP IF NOT A SEEK UUO
POPJ PP, ;SEEK, RETURN TO ***ACP***
POP PP,(PP) ;POP OFF RETURN ADR
TXNN AC16,V%READ ;INVALID-KEY EXITSKIP IF READ
AOS (PP) ;SKIP OVER THE OPERAND
MOVEI AC1,^D24 ;BOUNDRY VIOLATION
MOVEM AC1,FS.FS ;LOAD FILE-STATUS
PUSHJ PP,IVKSTS ;[601] BOUNDARY VIOLATION, SET FILE STATUS
JRST RET.2 ; AND TAKE A SKIP EXIT ***ACP***
>
;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, ;
IFN ANS74,<
;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,IVKSTS ;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
IFN ISAM,<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
TLNN AC1,-1 ; [641] IF GREATER THAN 777777
CAILE AC1,-11 ; [641] OR BETWEEN 777770 AND 777777
PUSHJ PP,FUSI ; DO A FILOP. TYPE USETI
XCT USETI. ; THIS IS THE BLOCK
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,
IFN ISAM,<
;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)
PUSHJ PP,VNDE1 ; READ FRESH COPY OF STATISTICS BLOCK
POPJ PP, ; NO NEW LEVELS EXIT
POPJ PP,
>
SUBTTL ISAM-CODE
IFN ISAM,<
;INDEX-SEQ READ
IREAD: SETZ FLG1, ;[605] INITIALIZE FLG1
PUSHJ PP,SETIC ;SET THE CHANNEL
HRR AC0,F.WBSK(I16)
HRRM AC0,GDPSK(I12)
AOS RWRSTA(I12) ;# OF READ/WRITE/REWRITES
IFN ANS74,< ;[605]
TXNE AC16,V%STRT ;[605] SKIP IF NOT START
JRST ISTRT ;[605] START GOES HERE
> ;[605]
PUSHJ PP,LVTST ;SYMKEY = LOW-VALUES ?
JRST SREAD ;YES, SEQUENTIAL READ
IFN ANS74,< ; 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
>;END IFN ANS74
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.
IFN ANS74,< ;[605]
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 = SYM-KEY FOUND
TXNE AC16,STA%EQ ;[605] SYM-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,NRESTS ;[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 = SYM-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
>;[605] END IFN ANS74
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:
IFN ANS74,< ;[605]
TXNE AC16,V%STRT ;[605] IS THIS START??
JRST RET.2 ;[605] YES, GIVE SKIP RETURN TO START IBS CALL
> ;[605]
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
IFN ANS68,<
TXNN AC16,V%READ ; READ?
AOS (PP) ;NO, RERITE OR DELET
>
IFN ANS74,<
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,NRESTS ;[601] SET NO RECORD ERROR
IFN ANS74,<
TXNE AC16,V%DLT ;; RERITE AND READ SKIP
POPJ PP, ;; DELETE ALREADY HAS A SKIP EXIT
>
JRST RET.2 ;INVALID-KEY RETURN
;SEQUENTIAL READ
SREAD: TLO FLG1,SEQ ;FLAG SREAD
IFN ANS74,<
SKIPLE SU.FRF ; IS THIS RETAIN OF DEL/REWRIT?
PUSHJ PP,SVDLRW ; YES, SAVE "CURRENT" RECORD POSITION
>
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
IFN ANS74,<
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
>;END IFN ANS74
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
IFN ANS74,<
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
TDNA ; 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
>; END IFN ANS74
;TRY FOR THE NEXT DATA REC IN THIS BLOCK
SREAD1: SETZ LVL, ;WE ARE AT LEVEL 0!
HRRZ AC4,CNTRY(I12) ;CURRENT ENTRY
SKIPE NNTRY(I12) ;CNTRY ALREADY POINTING AT NEXT ENTRY?
JRST SREAD2 ;YES
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] RETURN
;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,ENDSTS ;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 SYMBOLIC 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 SYM-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 SYMBOLIC-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 SYMKEY
LV2SK.:: MOVE AC1,F.WBSK(I16) ;SK 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 SYMKEY
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 SYM-KEY
;HERE TO DELETE A RECORD
DELET.: MRTMS. (AC1) ;START METER TIMING
SKIPE F.WSMU(I16) ;ANY RETAINED RECORDS?
PUSHJ PP,SU.DL ; YES
TXO AC16,V%DLT ;
JRST RERIT1 ;
;HERE TO REWRITE AN EXISTING RECORD
RERIT.: MRTMS. (AC1) ;START METER TIMING
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
IFN LSTATS,<
MOVE AC1,AC3 ;GET RECORD SIZE
PUSHJ PP,BUCREC ;SET AC2 TO REC BUCKET OFFSET
TXNE AC16,V%DLT ;DELETE?
JRST RERITN ;YES,JUMP
L.METR (MB.RWT(AC2),I16) ;NO, METER REWRITE BUCKET
JRST RERITO ;FINISH
RERITN: L.METR (MB.DEL(AC2),I16) ;METER DELETE BUCKET
RERITO:>;END IFN LSTATS
TXNE AC16,V%DLT ;IS IT DELET?
JRST RERIT3 ; YES,SKIP I-O CHECK
LDB AC3,WOPRS. ;NO,GET ACTUAL REC SIZE
IFN ANS74,<
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.
>;END IFN ANS74
RERIT3:
IFN ANS74,<
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
TRNE AC0,RDLAST ; WAS READ LAST IO OPERATION
JRST RERIT4 ; YES,CHECKS OK
JRST RERT3B ; NO GIVE ERROR CASE
RERT3A: HLRZ I12,D.BL(I16) ; GET BUFFER POINTER
SKIPN R.WRIT(I12) ; READ LAST I-O ?
JRST RANDOM ; YES,CHECKS OK
RERT3B: OUTSTR [ASCIZ/?READ must precede DELETE or REWRITE for SEQUENTIAL access files.
/];
JRST KILL ;GIT
RERIT4:
>; END IFN ANS74
; HERE FOR ISAM RERIT AND DELETE
PUSHJ PP,LVTST ;LOW-VALUES IN SYMBOLIC KEY?
JRST LVERR ;YES, ITS ILLEGAL
IFN ANS74,<
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
>; END IFN ANS74
RRIT2A: AOS RWRSTA(I12)
SETZ FLG1, ;[605] INITIALIZE FLG1 REG
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
MRTME. (AC1) ;END REWRITE TIMING
PUSHJ PP,CLRSTS ;[601] SET STATUS TO 00
HRRZ AC1,D.RFLG(I16) ; GET SOME FLAGS
TRZ AC1,RDLAST ; CLEAR READ LAST IO OPERATION
HRRM AC1,D.RFLG(I16) ; PUT THEM BACK
IFN ANS74,<
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
>
IFN ANS68,<
JRST RET.2
>
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: SETZ FLG1, ;[605] INITIALIZE FLG1 REG
PUSHJ PP,LVTST ;LOW VALUES IN SYM-KEY?
JRST LVERR ;ILLEGAL!
IFN ANS74,<
; CLEAR SAVED NEXT RECORD POSITION FLAG
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 IF WAS SET
>;END IFN ANS74
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 SYM-KEY
MOVEM AC0,GDX.I(I12) ;[465] AND USE DATA VS SYM-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 SYMKEY
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 SYM-KEY
PUSHJ PP,UDIF ;UPDATE THE INDEX FILE
PUSHJ PP,WIBK ;WRITE THE INDEX BLOCK
IWRIX: SKIPE OLDBK ;ANY BLOCKS TO DEALLOCATE
PUSHJ PP,DALC ;YES, DOIT
SKIPE F.WSMU(I16) ; SIMULTANEOUS - UPDATE?
PUSHJ PP,LRDEQX## ; YES
HRRZ AC1,D.RFLG(I16) ; GET SOME FLAGS
TRZ AC1,RDLAST ; CLEAR READ LAST IO OPERATION
HRRM AC1,D.RFLG(I16) ; PUT THEM BACK
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
MRTME. (AC1) ; END METER TIMING
JRST RET.2
IWIVK: SKIPN BRISK(I12) ;[466] SKIP IF NOT SLOW MODE
TLO FLG1,WIVK ;[466] SET FLAG
IWIVK2: 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,^D22 ;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,DPLSTS ;SET STATUS TO 22
MRTME. (AC1) ;END WRITE TIMING
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
IFE ANS74,<
;DELETE FOR NOW AS IT CAUSES NAVY TESTS IX104 & IX204 TO FAIL
SETOM FS.IF ;[462] TURN ON THIS IS ISAM FLAG
MOVE AC0,[E.FIDX+E.BIDX+^D27] ;[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
MOVE AC0,[E.FIDX+E.BIDX+^D2] ;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,^D30 ;RERMANENT ERROR
MOVEM AC0,FS.FS ;LOAD FILE-STATUS
SETOM FS.IF ;IDX FILE
MOVE AC0,[E.FIDX+E.BIDX+^D3] ;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,^D30 ;PERMANENT ERROR
MOVEM AC0,FS.FS ;LOAD FILE-STATUS
SETOM FS.IF ;IDX FILE
MOVE AC0,[E.FIDX+E.BIDX+^D36] ;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 SYMKEY
;ADJUST ONE TO MATCH IDXKEY, AND ONE TO RECKEY
ADJKEY: MOVE AC0,F.WBSK(I16) ;SYMBOLIC 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 ;SYMKEY
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 SYM-KEY
POPJ PP,
;CONVERT NUMERIC DISPLAY OR COMP-3 TO ONE/TWO WRD INTEGER
GD67: MOVEI AC0,ACSAV0 ;
BLT AC0,ACSAV0+16 ;
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 AC0,ACSAV0
BLT AC0,AC16
POPJ PP,
;GET SET FOR ONE/TWO WRD INTEGER
FPORFP: MOVE AC1,F.WBSK(I16) ;SYM-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) ;SYM-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) ;SYM-KEY
TLC AC0,1B18 ;
TLC AC3,1B18 ;
CAMG AC0,AC3 ;
JRST IBSGE ;SYM-KEY GT IDX-KEY
JRST IBSLT ;SYM-KEY LT IDX-KEY
;INDEX COMPARE ONE WORD SIGNED
IC1S: MOVE AC0,@IAKBP(I12) ;SYM-KEY
CAMGE AC0,2(AC10) ;
JRST IBSLT ;SYM-KEY LT IDX-KEY
JRST IBSGE ;SYM-KEY EQ OR GT IDX-KEY
;TWO WORD SIGNED
IC2S: MOVE AC0,@IAKBP(I12) ;SYM-KEY
CAMGE AC0,2(AC10) ;
JRST IBSLT ;SYM-KEY LT IDX-KEY
CAME AC0,2(AC10) ;
JRST IBSGE ;SYM-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 ;SYM-KEY EQ REC-KEY
DCDNN3: MOVE AC3,(AC1) ;
TLC AC0,1B18 ;
TLC AC3,1B18 ;
CAMG AC0,AC3 ;
JRST DSGT ;SYM-KEY GT REC-KEY
; JRST DSLT ;SYN-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 WRD 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 >
IFN LSTATS,<
MOVEM AC1,MRBNUM ;SAVE BLOCK NUMBER
PUSHJ PP,IOHSTR ;CALL HISTOGRAM ROUTINE
>
TLNN AC1,-1 ; [641] IF GREATER THAN 777777
CAILE AC1,-11 ; [641] OR BETWEEN 777770 AND 777777
PUSHJ PP,FIUSI ; DO A FILOP. TYPE USETI
XCT ISETI ;INDEX FILE
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: MOVE 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
MOVE AC0,[E.FIDA+E.BDAT+^D4] ;ERROR NUMBER
CAIE LVL,0 ;SKIP IF DATA BLOCK
MOVE AC0,[E.FIDX+E.BIDX+^D4] ;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: TLNN AC1,-1 ; [641] IF GREATER THAN 777777
CAILE AC1,-11 ; [641] OR BETWEEN 777770 AND 777777
PUSHJ PP,FUSI ; DO A FILOP. TYPE USETI
XCT 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: 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
;[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,^D30 ;PERMANENT ERROR
MOVEM AC0,FS.FS ;LOAD FILE-STATUS
SETOM FS.IF ;IDX FILE
MOVE AC0,[E.FIDX+^D35];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 ;
TLNN AC1,-1 ; [641] IF GREATER THAN 777777
CAILE AC1,-11 ; [641] OR BETWEEN 777770 AND 777777
PUSHJ PP,FUSO ; DO A FILOP. TYPE USETI
XCT USETO. ;
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: MOVE 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) ;
TLNN AC1,-1 ; [641] IF GREATER THAN 777777
CAILE AC1,-11 ; [641] OR BETWEEN 777770 AND 777777
PUSHJ PP,FIUSO ; USE FILOP. TYPE USETO
XCT ISETO ;
XCT IOUT ;
PUSHJ PP,CKFOI ;[523] DO CHECK POINT FILOP.(.FOURB)
WIBK2: MOVE AC0,CMDLST ; RESTORE AC0
CAMN AC0,IOWRD+13(I12);SAT BLOCK?
MOVE AC0,[E.BSAT] ;YES
CAMN AC0,IOWRD+14(I12);STATISTICS BLOCK?
MOVE AC0,[E.BSTS] ;YES
CAIG AC0,0 ;NONE OF THE ABOVE?
MOVE 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]
IFN LSTATS,<
MOVEM AC1,MRBNUM ;SAVE BLOCK NUMBER
PUSHJ PP,IOHSTR ;CALL I/O HISTOGRAM ROUTINE
>
TLNN AC1,-1 ; [641] IF GREATER THAN 777777
CAILE AC1,-11 ; [641] OR BETWEEN 777770 AND 777777
PUSHJ PP,FIUSI ; USE FILOP. TYPE USETI
XCT ISETI ;[307]
IFN ISTKS,<AOS INSSSS+14(I12) ;COUNT THE IN'S >
XCT IIN ;[307]
POPJ PP, ;[307]
MOVE 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)
IFN LSTATS,<
MOVEM AC1,MRBNUM ;BLOCK NUMBER
PUSHJ PP,IOHSTR ;CALL HISTOGRAM ROUTINE
>
TLNN AC1,-1 ; [641] IF GREATER THAN 777777
CAILE AC1,-11 ; [641] OR BETWEEN 777770 AND 777777
PUSHJ PP,FIUSI ; USE FILOP. TYPE USETI
XCT ISETI
IFN ISTKS,<AOS INSSSS+13(I12) ;COUNT THE IN'S >
XCT IIN
POPJ PP,
MOVE 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:
IFN ANS74,<
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
MOVBXT:
IFN LSTATS,<
MOVE AC1,D.CLRR(I16) ;GET REC LENGTH
PUSHJ PP,BUCREC ;SET AC2 TO REC BUCKET OFFSET
L.METR (MB.RDD(AC2),I16) ;CNT READ BUCKET
MRTME. (AC1) ;END TIMING,UPDATE TIME BUCKET
>;END IFN LSTATS
; 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
IFN ANS74,<
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
>
SKIPE F.WSMU(I16) ; SIMULTANEOUS - UPDATE?
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
HRRZ AC1,D.RFLG(I16) ; GET SOME FLAGS
TRO AC1,RDLAST ; SET READ LAST IO OPERATION
HRRM AC1,D.RFLG(I16) ; PUT THEM BACK
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. ;
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: 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
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
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
MOVE AC0,[E.FIDX+E.BSAT+^D5] ;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
;POPJ IF SYMKEY = LOW-VALUES, SKIP EXIT IF NOT
LVTST: HLRZ I12,D.BL(I16) ;SETUP I12
IFN ANS74,<
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 SRTING 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 SRTING 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 /SYMBOL-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
MOVE AC0,[E.FIDX+^D1] ;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,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)
; NOW RESET BACK TO LAST POSITION BEFORE DOING CHK-PNT
MOVE AC1,D.CBN(I16) ; CURRENT BLOCK
TLNN AC1,-1 ; [641] IF GREATER THAN 777777
CAILE AC1,-11 ; [641] OR BETWEEN 777770 AND 777777
PUSHJ PP,FUSO ; DO A FILOP. TYPE USETO
XCT 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,<
SKIPE M7.00 ;IF 7.00
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,<
SKIPE M7.00 ;IF 7.00
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
> ;END IFN ISAM
;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 RET.2 ; ERROR RETURN
JRST RET.2 ; 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 RET.2 ; ERROR RETURN
JRST RET.2 ; 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,^D18
TXNE AC2,IO.DER ;DEVICE ERROR
MOVEI AC1,^D19
TXNE AC2,IO.DTE ;DATA ERROR
MOVEI AC1,^D20
TXNE AC2,IO.BKT ;QUOTA EXCEEDED, FILE STR, OR RIB FULL
MOVEI AC1,^D21
TXNE AC2,IO.EOF ;EOF
MOVEI AC1,^D22
MOVEI AC3,^D34 ;ASSUME DSK FULL
TXNE AC2,IO.BKT ;IS IT?
JRST IGMD2 ;YES
SKIPN AC3,FS.FS ;NO CHANGE IF NON ZERO
MOVEI AC3,^D30 ;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: TXNE AC16,CLS%EF!CLS%EV!CLS%BV
ADD AC0,[EXP E.VCLO]
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
ADDI AC3,1 ;PLUS ONE
SKIPG AC3 ;UNLESS ITS NEGATIVE
SETZM 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
IFN ISAM,<
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:
IFN ANS74,<
MOVE AC1,FS.FS ;GET ERROR CODE
CAIN AC1,^D10 ;END-OF-FILE ONLY?
JRST IGTST2 ;YES
>
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
; 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
ENDSTS: MOVEI AC0,^D10 ; [601]READ INVALID KEY
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
DPLSTS: 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
NRESTS: MOVEI AC0,FSNRCF ;[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
IVKSTS: 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
JUMPE AC16,RRDMP2 ;
MOVE AC13,D.DC(I16) ;DEVCHR TO 13
MOVE FLG,F.WFLG(I16) ;FLAGS TO FLG
JRST RRDMP5 ;
RRDMP0: PUSHJ PP,RRERR0 ;"DUMP ABORTED"
OUTSTR [ASCIZ / IO/]
JRST RRDMP9 ;EXIT, NO DUMP
;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
TLNN AC1,-1 ; [641] IF GREATER THAN 777777
CAILE AC1,-11 ; [641] OR BETWEEN 777770 AND 777777
PUSHJ PP,FUSI ; DO A FILOP. TYPE USETI
XCT USETI. ;
JRST RRDMP3 ;CONT LOOP
RRDMP5: 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: TLNN AC1,-1 ; [641] IF GREATER THAN 777777
CAILE AC1,-11 ; [641] OR BETWEEN 777770 AND 777777
PUSHJ PP,FUSO ; DO A FILOP. TYPE USETO
XCT 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]
IFE LSTATS,<
XCT AC6
TRNA
JRST RRERR2 ;OUTPUT ERROR
>;END IFE LSTATS
IFN LSTATS,<
SKIPN MRRERN ;DID WE RESTART WITH RERUN BEFORE?
JRST MNORRN ;NO, OK TO SET AND CLEAR "RERUNNING" FLAG
;WE RESTARTED THE PROGRAM USING RERUN AND NOW WE ARE DOING ANOTHER DUMP.
; THE FLAG "MRRERN" MUST STAY SET TO -1, SO NO OUTPUT GETS DONE TO MTO FILE.
XCT AC6 ;DO OUTPUT
JRST RROUOK ;ALL OK
JRST RRERR2 ;OUTPUT ERROR
;THE PROGRAM HAS NOT BEEN "RERUN". SET THE FLAG MRRERN TO -1 SO
;THAT IF WE ^C AND RUN RERUN LATER, THE PROGRAM WILL NOT TRY AND WRITE
;BAD INFORMATION INTO THE .MTO FILE.
MNORRN: SETOM MRRERN ;WE'LL SET AND CLEAR FLAG THIS TIME
XCT AC6 ;DO OUTPUT
JRST [SETZM MRRERN ;ALL OK, CLEAR FLAG
JRST RROUOK]
JRST [SETZM MRRERN ;OUTPUT ERROR..BUT CLEAR FLAG ANYWAY
JRST RRERR2] ;SO WE GET THE INFO COLLECTED SO FAR
RROUOK:
>;END IFN LSTATS
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
IFN 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 SYMBOLIC KEYS.
KY.SIZ: POINT 12,KEYDES(I12),35 ; KEY SIZE
>
DTCN.: POINT 4,D.CN(I16),15 ; CHANNEL NUMBER
UUOCHN: POINT 4,UOPEN.,12 ; CHANNEL NUMBER AS SET IN OPEN UUO XCT WORD
DTIBS.: POINT 6,D.IBB(I16),11 ; INPUT HEADER BYTE SIZE
DTOBS.: POINT 6,D.OBB(I16),11 ; OUTPUT HEADER BYTE SIZE
DTRN.: POINT 12,D.RN(I16),11 ; MTA REEL NUMBER
F.QOPN: POINT 1,F.WSMU(I16),15 ;[565] LFENQ. OPEN FLAG
;[565] 0= NOT AFTER LFENQ. OPEN
;[565] 1= AFTER LFENQ. OPEN
F.BNDV: POINT 6,F.WNOD(I16),17 ;NUMBER OF DEVICES SELECTED
F.BLF:: F%BLF ;LOCK FLAG
F.BCVR: F%BCVR ; COMPILER'S VERSION NUMBER
F.BBLC:: F%BBLC ; BUFFER LOCATION IS ASSIGNED - BUFLOC
F.BSDF: F%BSDF ; SORT-DESCRIPTION FILE FLAG - SRTFIL
F.BDRM: F%BDRM ; OPEN REVERSED ACTIVE FLAG
F.BNOD: F%BNOD ; NUMBER OF DEVICES ASSIGNED TO FILE
IFN ANS68,<
F.BNFL: F%BNFL ; NUMBER OF FILE LIMIT CLAUSES
>
IFN ANS74,<
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 ALTERNATE BUFFERS
F.BRMS:: F%BRMS ; THE RMS FILE FLAG
F.BMRS:: F%BMRS ; MAXIMUM 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
;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
SUBTTL METERING STUFF
IFN CSTATS,<
IFE TOPS20,<
;TOPS10 CSTATS ROUTINE TO GET A FREE CHANNEL
; RETURNS .+1 IF NONE AVAILABLE, ELSE .+2 WITH NUMBER IN RH(AC5)
GMCHAN: SKIPN AC5,OPNCH. ;ANY CHANNELS AVAIL?
POPJ PP, ;NO
MOVE AC6,OPNCBP ;GET BYTE PTR
HRRI AC5,1 ;START WITH 1
MOVEI AC2,17 ; UPPER LIMIT
GMCHN2: ILDB AC11,AC6
SOJE AC11,GMCHN1 ; SEE GCHAN. ROUTINE
CAILE AC2,(AC5)
AOJA AC5,GMCHN2
GMCHN0: SETZB AC5,AC11 ;USE CHANNEL 0 IF NONE OTHER FREE
GMCHN1: DPB AC11,AC6 ;NOTE CHANNEL UNAVAILABLE
JRST RET.2 ;GIVE SKIP RETURN
>;END IFE TOPS20
>;END IFN CSTATS
;METER--ING STUFF
;CALL: MOVEI 16,NUMBER
; PUSHJ 17,METER.
; <RETURN HERE>
METER.:
IFE CSTATS,<
POPJ PP, ;JUST RETURN IF WE EVER GET HERE
>
IFN CSTATS,<
IFN TOPS20,<
EXCH 16,PBUKET ;GET PREVIOUS BUCKET IN 16, SAVE NEW
;PREVIOUS BUCKET
AOS MTRNUM(16) ;ANOTHER ONE OF THESE
PUSH PP,1 ;SAVE 1 AND 2
PUSH PP,2
MTRJS% ;GET NEW CLOCK TIME IN 1,2
ERJMP .+6 ;ERROR
DMOVE 14,1 ;SAVE IN 14, 15
DSUB 1,PCLOCK ; GET INCREMENTAL CLOCK TIME
ASHC 1,^D24 ; SHIFT INTO 36 BIT VALUE
ADDM 1,MTRTIM(16) ;INCREMENT TIME
DMOVEM 14,PCLOCK ;SAVE NEW "PREVIOUS" CLOCK TIME
POP PP,2
POP PP,1
POPJ PP, ;RETURN
>;END IFN TOPS20
IFE TOPS20,<
; WE CAN SMASH AC14 AT THE METER--JSYS STATEMENT (NOBODY ELSE CARES)
HRRZ AC14,METR. ;AC14 POINTS TO START OF THE METER BUCKETS
EXCH 16,PBUKET(AC14) ;GET PREVIOUS BUCKET, STORE NEW ONE
ADD 16,AC14 ; 16 POINTS TO COUNTER FOR OLD BUCKET
AOS (16) ; COUNT THIS OCCURANCE
POPJ PP, ;AND RETURN
>;END IFE TOPS20
IFN TOPS20,<
;THE TABLES
MTRST==. ;START OF INFO
; *** DANGER !!!! ENRAGED CROCK APPROACHING !!! ***
MTRNUM: BLOCK ^D500 ;NUMBER OF TIMES THINGS WERE DONE
EXP 1
BLOCK ^D499
EXP 1
BLOCK ^D499
EXP 1
BLOCK ^D499
EXP 1
BLOCK ^D498
EXP 1
MTRTIM: BLOCK ^D500 ; TIMINGS
EXP 1
BLOCK ^D499
EXP 1
BLOCK ^D499
EXP 1
BLOCK ^D499
EXP 1
BLOCK ^D499
;*** END OF CROCK ***
MTREND==.-1 ;END
MTRLEN==MTREND-MTRST ;LENGTH OF THINGS TO WRITE OUT
METRNM: BLOCK 3 ;ASCIZ NAME OF FILE
PCLOCK: BLOCK 2 ;PREVIOUS VALUE RETURNED BY METER JSYS
PBUKET: BLOCK 1 ;PREVIOUS BUCKET NUMBER
>;END IFN TOPS20
;ROUTINE TO DO SETUP IF METR. WAS SET
; CALLED BY RESET CODE
SETMTR:
IFN TOPS20,<
MOVEI MTRNUM ;MAKE METR. POINT
MOVEM METR.## ; TO THE COUNTER TABLE
>;END IFN TOPS20
IFE TOPS20,<
METRLN==^D2500 ;NUMBER OF BUCKETS TO WRITE OUT
MTRNM6==0+METRLN ;SIXBIT NAME OF FILE
METRNM==1+METRLN ;ASCIZ NAME OF FILE
PBUKET==4+METRLN ;PREVIOUS BUCKET NUMBER
METCLN==5+METRLN ; NUMBER OF LOWSEG LOCS WE NEED
;CALL FUNCT. TO GET CORE AT PAGE BOUNDARY
;STORE POINTER IN METR.
MOVEI 16,1+[-5,,0
XWD 0,FUN.A0##
XWD 0,[ASCIZ/LBL/]
XWD 0,FUN.ST##
XWD 0,FUN.A1##
XWD 0,FUN.A2##]
F.PAG==15
MOVEI 1,F.PAG ;FUNCTION WE WANT
MOVEM 1,FUN.A0## ;STORE FUNCTION
SETZM FUN.ST## ;CLEAR STATUS
SETZM FUN.A1## ; AND ADDRESS RETURNED
MOVEI 1,METCLN ;NUMBER OF WORDS TO ALLOCATE
MOVEM 1,FUN.A2## ;STORE AS ARG #2
PUSHJ PP,FUNCT.## ;CALL FUNCT. ROUTINE...
SKIPE FUN.ST## ; STATUS MUST BE 0...
JRST METNCR ; ? NOPE - NO CORE AVAIL
HRRZ 1,FUN.A1## ;GOT IT -- GET ADDRESS OF START
MOVEM 1,METR. ;STORE IN METR.
>;END IFE TOPS20
MOVEI MTRREE ;SET REENTER ADDRESS
MOVEM .JBREN ; (NOTE: RERUN DUMPS WON'T WORK)
IFN TOPS20,<
SETZM MTRNUM+^D500 ;GET RID OF THE 1'S
SETZM MTRNUM+^D1000
SETZM MTRNUM+^D1500
SETZM MTRNUM+^D2000
SETZM MTRTIM-1
SETZM MTRTIM+^D500
SETZM MTRTIM+^D1000
SETZM MTRTIM+^D1500
SETZM MTRTIM+^D2000
GETNM ;GET SIXBIT NAME OF PROGRAM
SKIPN 1
MOVE 1,[SIXBIT/METER/] ;DEFAULT NAME
>;END IFN TOPS20
IFE TOPS20,<
HRROI 1,.GTPNM
GETTAB 1,
TRNA ;IF GETTAB FAILS, USE DEFAULT
SKIPN 1
MOVE 1,[SIXBIT/METER/]
HRRZ 2,METR.
MOVEM 1,MTRNM6(2) ;STORE NAME
>;END IFE TOPS20
MOVE 0,1
SETZ 1, ;MAKE SURE LAST BYTE IS 0
MOVSI 2,(POINT 6,0)
MOVE 3,[POINT 7,METRNM]
IFE TOPS20,<
ADD 3,METR. ;ADD INDEX TO GET REAL ADDRESS
>;END IFE TOPS20
SETMT1: ILDB 4,2
JUMPE 4,SETMT2
ADDI 4,40
IDPB 4,3
JRST SETMT1
SETMT2: MOVE 2,[POINT 7,[ASCIZ/.DYN/]]
SETM2A: ILDB 4,2
JUMPE 4,SETMT3 ;DONE MAKING THE STRING
IDPB 4,3
JRST SETM2A
SETMT3: SETZ 4,
IDPB 4,3
POPJ PP, ;ALL DONE!
IFE TOPS20,<
; COME HERE IF COULDN'T GET CORE FOR METER--ING
METNCR: OUTSTR [ASCIZ/? Not enough core for meter--ing.
/]
SETZM METR.## ;CLEAR LOCATION
JRST KILL. ;PUNT!
>;END IFE TOPS20
;HERE IF HE DID A ^C REENTER
MTRREE: IFE TOPS20, JRST 1,.+1 ;PORTAL IF TOPS10
PUSHJ PP,WRTMET ;WRITE IT OUT
EXIT ;AND EXIT
;ROUTINE TO WRITE IT OUT
; CALL: PUSHJ PP,WRTMET
; <RETURN HERE, EVEN IF ERRORS>
WRTMET: SKIPN METR. ;IF METER--ING WAS DONE, WRITE THE FILE
POPJ PP,
OUTSTR [ASCIZ/[Writing METER file: /]
IFN TOPS20, OUTSTR METRNM
IFE TOPS20,<
HRRZ 1,METR.
OUTSTR METRNM(1)
>
OUTSTR [ASCIZ/]
/]
IFN TOPS20,<
MOVX 1,GJ%FOU!GJ%SHT
HRROI 2,METRNM
GTJFN%
ERJMP METRRR
MOVX 2,OF%WR
OPENF%
ERJMP METRRR
MOVE 2,[444400,,MTRST]
MOVNI 3,MTRLEN
SOUT%
CLOSF%
ERJMP METRRR ;JSYS ERROR
POPJ PP,
METRRR: HRROI 1,[ASCIZ/?JSYS error: /]
PSOUT%
MOVEI 1,.PRIOU
HRLOI 2,.FHSLF
SETZ 3,
ERSTR%
JFCL
JFCL
HRROI 1,[ASCIZ/ for METER file /]
PSOUT%
HRROI 1,METRNM
PSOUT%
HRROI 1,[ASCIZ/
/]
PSOUT%
POPJ PP,
>;END IFN TOPS20
IFE TOPS20,<
;FIND A FREE CHANNEL, WRITE OUT THE FILE WITH DUMP MODE IO,
; RELEASE THE CHANNEL & POPJ
PUSHJ PP,GMCHAN ;GET A FREE CHANNEL TO USE
JRST [OUTSTR [ASCIZ/? No free channels to write METER file.
/]
POPJ PP,] ;JUST GIVE IT UP
ANDI AC5,17 ;JUST SAVE CHANNEL NUMBER
DPB AC5,[POINT 4,AC5,12] ;SAVE IN AC FIELD OF AC5
HLLZ AC5,AC5 ;FOR MAKING UUOS
;DO OPEN UUO
MOVEI AC1,.IODMP ;BINARY DUMP MODE
MOVSI AC2,'DSK' ; TO DEVICE "DSK"
SETZ AC3, ;NO BUFFER HEADERS
MOVE AC0,[OPEN AC1]
OR AC0,AC5 ;READY TO DO IT
XCT AC0
JRST GMOPNF ; ?OPEN UUO FAILED
;DO ENTER UUO
HRRZ AC1,METR.
MOVE AC1,MTRNM6(AC1)
MOVSI AC2,'DYN'
SETZB AC3,AC4
MOVE AC0,[ENTER AC1]
OR AC0,AC5
XCT AC0
JRST GMENTF ; ?ENTER UUO FAILED
;DO OUT UUO
MOVNI AC1,METRLN
HRLZ AC1,AC1 ;-NUMBER OF WORDS TO WRITE OUT,,0
HRR AC1,METR. ; GET RH= ADDRESS-1
SUBI AC1,1
SETZ AC2,
MOVE AC0,[OUT AC1]
OR AC0,AC5
XCT AC0
TRNA ;OK
JRST GMOUTF ; ?OUT UUO FAILED
;DO RELEAS UUO
GMRELS: MOVSI AC0,(RELEAS 0,)
OR AC0,AC5
XCT AC0
POPJ PP, ;AND RETURN FROM THIS ROUTINE
GMOPNF: OUTSTR [ASCIZ/? OPEN failed for METER file.
/]
GMGIVU: OUTSTR [ASCIZ/% METER file not written.
/]
JRST GMRELS
GMENTF: OUTSTR [ASCIZ/? ENTER filed for METER file.
/]
JRST GMGIVU ;GIVE UP
GMOUTF: OUTSTR [ASCIZ/? OUT UUO failed for METER file.
/]
JRST GMGIVU ;GIVE UP
>;END IFE TOPS20
>;END IFN CSTATS
IFN LSTATS,<
SUBTTL LSTATS - I/O HISTOGRAM ROUTINE
;THE I/O HISTOGRAM ROUTINE
;CALL WITH THE BLOCK NUMBER TO BE READ IN MRBLKO
; THE CHANNEL NUMBER OF THE FILE IS AVAILABLE BY
;EXTRACTING IT FROM THE "INPUT UUO", WHICH IS ABOUT TO BE XCT'D.
;
;ALL ACS ARE SAVED
;
; CALCULATE THE OVERHEAD TIME FOR METERING DISK USAGE
;BY SAVING THE TIME AT METERING BEGIN (IN LOCATION MRBLKO)
;AND THEN USING IT TO CALCULATE TIME SPENT IN METERING. THIS
;TIME IS ADDED TO ANY EXISTING LIBOL METER POINT START TIME
;(IN LOCATION MBTIM.) TO CANCEL OUT THIS OVERHEAD.
IOHSTR: PUSH PP,AC10 ;SAVE AC10 AND AC11
PUSH PP,AC11
IFN TOPS20,<
DMOVE AC10,AC1 ;SAVE AC1 AND AC2 IN AC10 AND AC11
MTRJS% ;GET FAST METER TIME IN AC1&AC2
ERJMP .+2 ;ERRORS SKIP
DMOVEM AC1,MRBLKO ;SAVE OVERHEAD START TIME
>;END IFN TOPS20
IFE TOPS20,<
SETZB AC10,AC11 ;CLEAR AC10 AND AC11
RUNTIME AC10, ;GET FAST 10 TIME IN AC10
>;END IFE TOPS20
;UPDATE MOST-RECENTLY USED TABLE OF FILE NUMBER AND PAGE NUMBER
PUSH PP,AC1 ;SAVE ACS USED
PUSH PP,AC2
PUSH PP,AC3
PUSH PP,AC4
;IF AN OLD ENTRY IS IN THE TABLE, UPDATE HISTOGRAM.
; THE ENTRY WILL ALWAYS END UP AT THE BOTTOM OF THE TABLE (MOST
; RECENTLY USED).
HRRZ AC2,MRTDBP ;ADDRESS OF TRAILER BLOCK
AOS MB.HTC(AC2) ; REMEMBER ROUTINE WAS DONE ANOTHER TIME
HRRZ AC4,MRBNUM ;GET BLOCK NUMBER
IFN TOPS20, LSH AC4,-2 ;(PAGE NUMBER IF TOPS20)
LDB AC3,[POINT 4,UIN.,12] ;GET CHANNEL NUMBER= FILE NUMBER
HRL AC4,AC3 ;LH(AC4) = FILE #, RH (AC4)= BLOCK NUMBER
;LOOK FOR ENTRY IN THE TABLE, BOTTOM-UP.
; IF NOT FOUND, MOVE THE WHOLE TABLE UP WITH A BLT AND
; ADD IT TO THE BOTTOM.
;IF ENTRY IS ALREADY IN TABLE, MOVE UP ENTRIES BELOW IN
;(ERASING THE OLD ENTRY) AND PUT NEW ENTRY AT THE BOTTOM;
;THEN INCREMENT THE APPROPRIATE HISTOGRAM BUCKET.
HRRZ AC2,MRFPGT ;POINT TO THE TABLE
MOVEI AC3,MBHISL-1(AC2) ; AC3 POINTS TO LAST ENTRY
MRFLUP: CAMN AC4,(AC3) ; FOUND ENTRY?
JRST MRFNDE ;YES, MOVE UP REST OF TABLE
SUBI AC3,1
CAIL AC3,(AC2) ;AT START OF TABLE YET?
JRST MRFLUP ;NO, KEEP SEARCHING
;ENTRY WAS NOT IN TABLE. BLT UP WHOLE TABLE, AND PUT IT
; AT THE BOTTOM.
MOVSI AC1,1(AC2) ;ST+1
HRRI AC1,(AC2) ;ST
ADDI AC2,MBHISL-1 ;POINT TO LAST ENTRY IN TABLE
BLT AC1,-1(AC2) ; MOVE UP TABLE, ERASE TOP ENTRY
MOVEM AC4,(AC2) ;STORE MOST RECENTLY USED ENTRY AT END
JRST NOHADD ; DONE--DON'T INCREMENT ANY HISTOGRAM BUCKETS
;ENTRY FOUND.. AC3 POINTS TO IT. MOVE UP TABLE SUCH THAT IT ERASES
; THIS ENTRY BUT LEAVES THE ONES ABOVE IT IN PLACE, THEN ADD NEW
; ENTRY TO THE BOTTOM. THE NET EFFECT IS TO HAVE THE SAME ENTRIES
; IN THE TABLE, BUT IN A DIFFERENT ORDER (MOST RECENTLY USED AT THE
; BOTTOM).
MRFNDE: HRLI AC1,1(AC3) ;FROM: THIS ENT+1
HRRI AC1,(AC3) ;TO: THIS ENT
BLT AC1,MBHISL-2(AC2); BLT TO LAST ENTRY-1
MOVEM AC4,MBHISL-1(AC2) ;STORE THIS ENTRY AT END.
HRRZ AC4,MRTDBP ;POINT TO TRAILER BLOCK
SUBI AC2,-MBHISL+1(AC3); END - ENTRY = HISTOGRAM BUCKET TO AOS
ADDI AC4,MB.HTO(AC2) ; POINT TO THE HISTOGRAM BUCKET
AOS (AC4) ;INCREMENT IT
NOHADD: POP PP,AC4 ;RESTORE ACS USED
POP PP,AC3
POP PP,AC2
POP PP,AC1
IFN TOPS20,<
MTRJS% ;GET FAST TIME IN AC1 AND AC2
ERJMP RST111 ;SKIP THE TIME CALC IF ERROR
DSUB AC1,MRBLKO ;SUB START TIME
DADD AC1,MRBKO. ;ADD IN FIXED OVERHEAD
DADD AC1,MBTIM. ;ADD TO METER POINT START TIME
DMOVEM AC1,MBTIM. ;RESTORE METER POINT START TIME
DMOVE AC1,AC10 ;RESTORE AC1 AND AC2
>;END IFN TOPS20
IFE TOPS20,<
RUNTIME AC11, ;GET FAST 10 TIME IN AC11
SUB AC11,AC10 ;SUB OUT START TIME
ADD AC11,MRBKO. ;ADD IN FIXED OVERHEAD TIME
ADDM AC11,MBTIM. ;UPDATE METER RPOINT START TIME
>;END IFE TOPS20
RST111: POP PP,AC11 ;RESTORE AC11 AND AC10
POP PP,AC10
POPJ PP, ;RETURN
;CLRFBT - ROUTINE TO CLEAR OUT ENTRIES OF THIS FILE IN THE
;FILE/BLOCK TABLE, BECAUSE WE ARE CLOSING THE FILE
;SAVES ALL ACS
CLRFBT: PUSH PP,AC1 ;SAVE ACS USED
PUSH PP,AC2
PUSH PP,AC3
HRRZ AC1,MRFPGT ;POINT TO THE TABLE
ADDI AC1,MBHISL-1 ;POINT TO LAST ENTRY
LDB AC2,DTCN. ;GET CHANNEL NUMBER= FILE NUMBER
CLRBFL: HLRZ AC3,(AC1) ;GET AN ENTRY
CAMN AC2,AC3 ; SAME FILE NUMBER?
SETZM (AC1) ;YES, DELETE IT
CAME AC1,MRFPGT ;REACHED TOP?
SOJA AC1,CLRBFL ;NO, LOOP
POP PP,AC3
POP PP,AC2
POP PP,AC1
POPJ PP, ;RETURN
SUBTTL LSTATS - TIMING ROUTINES
;LMETR. IS THE ROUTINE THAT INCREMENTS THE LIBOL BUCKET NUMBER
;INDICATED AND SAVES THE ADDRESS OF THE TIME BUCKET TO BE
;UPDATED.
; ARGUEMENTS: AC2= BUCKET OFFSET WITHIN THE BUCKET BLK
; AC1= ADDRESS OF THE PROPER FILTAB
;
; SETS: MRTMB. (THE ADDRESS OF THE TIME BUCKET)
LMETR.: LDB AC1,[POINT 4,D.CN(AC1),15] ;GET CHAN #
ADD AC2,MROPTT(AC1) ;ADD ADDRESS OF MTR BLK TO OFFSET
AOS (AC2) ;INCREMENT BUCKET
ADDI AC2,1 ;ADDRESS TIME BUCKET
MOVEM AC2,MRTMB. ;SAVE TIME BUCKET ADDRESS
POPJ PP, ;RETURN
; MRACDP IS THE METER POINT ROUTINE FOR ACCEPT AND
;DISPLAY. THESE METER BUCKETS ARE IN THE TRAILER BLOCK,
;SINCE THEY ARE IN NO WAY RELATED TO ANY PARTICULAR FILE.
;
;ARGUEMENT: AC2= THE OFFSET FOR THE BUCKET,RELATIVE TO
; THE BASE OF THE TRAILER BLOCK
;USES: AC1
;
MRACDP: MRTMS. (AC1) ;START METER TIMING
ADD AC2,MRTDBP ;ADD IN TRAILER BASE ADDRESS
AOS (AC2) ;INCREMENT BUCKET
ADDI AC2,1 ;ADDRESS TIME BUCKET
MOVEM AC2,MRTMB. ;SAVE TIME BUCKET ADDRESS
SETZ AC2, ;CLEAR AC2,USED IN DISPLAY AS A FLAG
POPJ PP, ;RETURN
;MRTM.S AND MRTM.E ARE THE LIBOL METERING TIME ROUTINES.
;MRTM.S SETS THE START TIME .
;MRTM.E ENDS THE TIMING AND UPDATES THE TIME BUCKET
;INDICATED BY MRTMB.
IFN TOPS20,<
IFNDEF METER%,< ;IF METER% JSYS UNDEFINED, THIS IS BEFORE RELEASE 4
MRTM.S: PUSH PP,AC1 ;SAVE AC1
PUSH PP,AC2 ;SAVE AC2
MTRJS% ;GET FAST CLOCK TIME IN AC1& AC2
ERJMP .+2 ;ERROR SKIP TIME SET
DMOVEM AC1,MBTIM. ;SAVE START TIME
POP PP,AC2 ;RESTORE AC2
POP PP,AC1 ;RESTORE AC1
POPJ PP, ;RETURN
MRTM.E: PUSH PP,AC1 ;SAVE AC1
PUSH PP,AC2 ;SAVE AC2
MTRJS% ;GET FAST CLOCK TIME IN AC1&AC2
ERJMP .+4 ;ERROR, SKIP TIME CALC
DSUB AC1,MBTIM. ;SUB START TIME
ASHC AC1,^D24 ;SHIFT TO SINGLE WORD
ADDM AC1,@MRTMB. ;ADD TO TIME BUCKET
POP PP,AC2 ;RESTORE AC2
POP PP,AC1 ;RESTORE AC1
POPJ PP, ;RETURN
>;END IFNDEF METER%
IFDEF METER%,< ;RELEASE 4 SYSTEM -- USE MONITOR JSYS
MRTM.S: PUSH PP,AC1 ;SAVE 3 ACS
PUSH PP,AC2
PUSH PP,AC3
MOVEI AC1,.MEREA ;READ E-BOX TICKS
METER% ;GET FAST CLOCK TIME IN AC2&AC3
ERJMP .+2 ;ERROR, SKIP TIME CALC
DMOVEM AC2,MBTIM. ;SAVE START TIME
POP PP,AC3
POP PP,AC2
POP PP,AC1
POPJ PP,
MRTM.E: PUSH PP,AC1
PUSH PP,AC2
PUSH PP,AC3
MOVEI AC1,.MEREA ;E-BOX TICKS
METER% ;GET FAST CLOCK TIME IN AC2& AC3
ERJMP .+4 ;ERROR, SKIP TIME CALC
DSUB AC2,MBTIM. ;SUB START TIME
ASHC AC2,^D24 ;SHIFT TO SINGLE WORD
ADDM AC2,@MRTMB. ;ADD TO TIME BUCKET
POP PP,AC3 ;RESTORE AC3
POP PP,AC2 ;RESTORE AC2
POP PP,AC1 ;RESTORE AC1
POPJ PP, ;RETURN
>;END IFDEF METER%
>;END IFN TOPS20
SUBTTL LSTATS - ROUTINES TO CALCULATE BUCKET OFFSETS
;BUCREC IS A ROUTINE TO CALCULATE THE BUCKET OFFSET FOR
;READ,WRT,ETC. GIVEN THE RECORD SIZE. THE BUCKETS ARE
;ALLOCATED FOR SIZES 72,80,132 (CHARS) ,128 AND 512 (WORDS)
;AND THE SPACES IN BETWEEN THEM.
;
; ARGUMENTS: AC1= REC SIZE IN CHARS
;
; RETURNS: AC2= BUCKET OFFSET
;
; AC1 IS NOT PRESERVED.
BUCREC: SETZ AC2, ;CLEAR OFFSET
CAILE AC1,^D132 ;.LE. 132?
JRST BUCRE2 ;NO,TEST WORD LENGTHS
CAIE AC1,^D132 ;
JRST BUCRE0 ;.LT.132
ADDI AC2,5 ;= 132, OFFSET=5
JRST BUCREX ;EXIT
BUCRE0: CAIGE AC1,^D80 ;
JRST BUCRE1 ;.LT. 80
CAIE AC1,^D80 ;
ADDI AC2,1 ;.GT. 80, OFFSET=4
ADDI AC2,3 ;= 80, OFFSET=3
JRST BUCREX ;EXIT
BUCRE1: CAILE AC1,^D72 ;
AOJA AC2,.+2 ;.GT.72&.LT.80, OFFSET=2
CAIL AC1,^D72 ;
ADDI AC2,1 ;= 72, OFFSET=1
JRST BUCREX ;.LT. 72, OFFSET=0
BUCRE2: MOVE AC2,D.BPW(I16) ;GET BYTES PER WORD
IDIV AC1,AC2 ;CALC WDS PER REC
JUMPE AC2,.+2 ;SKIP IF NO REMAINDER
ADDI AC1,1 ;ROUND UP
SETZ AC2, ;CLEAR THE OFFSET
CAILE AC1,^D128 ;
JRST BUCRE3 ;.GT.128 WORDS
CAIL AC1,^D128 ;
ADDI AC2,1 ;=128 WORDS, OFFSET=7
ADDI AC2,6 ;.LT.128 WORDS, OFFSET=6
JRST BUCREX ;EXIT
BUCRE3: CAILE AC1,^D512 ;
AOJA AC2,.+2 ;.GT.512 WORDS, OFFSET=10
CAIL AC1,^D512 ;
ADDI AC2,1 ;=512 WORDS, OFFSET=9
ADDI AC2,^D8 ;.LT.512 WORDS, OFFSET=8
BUCREX: LSH AC2,1 ;MULTIPLY BY 2,ALLOWING FOR TIME BKTS
POPJ PP, ;RETURN
>;END IFN LSTATS
C.END: END