Trailing-Edge
-
PDP-10 Archives
-
decuslib10-10
-
43,50517/cblio.mac
Click 43,50517/cblio.mac to
see without markup as text/plain
There are 21 other files named cblio.mac in the archive. Click here to see a list.
TITLE CBLIO FOR LIBOL 16-JAN-75
SUBTTL EDIT HISTORY
;COPYRIGHT 1974, 1975 DIGITAL EQUIPMENT CORP., MAYNARD, MASS.
EDIT==420
;********* MODIFIED TO SUPPORT RPGII 5/29/76 *********
;
;ALL RPGII MODIFICATIONS COPYRIGHT 1976, BOB CURRIER AND CERRITOS COLLEGE
;***** V10 *****
; 420 17-OCT-75 JEC
; FIX SPACING WITH NO PAGE HEADER. - LINE -
; 417 21-OCT-75 JEC
; MAKE SURE THAT CSORT TAKES NO MORE THAN 6 CHANNELS - CSORT -
; 416 25-SEP-75 JEC
; FIXED FUNCOR ROUTINE TO RETURN START ADDRESS.
; NOT IN V10 - COBFUN WAS EXTENSIVLY MODIFIED WHICH FIXED THE PROBLEM.
; 415 25-SEP-75 JEC
; FIX EDIT 334 SO THAT SINGLE DIGTIT TESTS WORK.
; NOT IN V10 - NUMBRS WAS REWRITTEN.
; 414 27-AUG-75 JEC SPR-16722
; PUT IN INTERRUPT CODE FOR ON-LINE PRINTER AND SET LPT BUFFER TO 1.
; 413 30-JUN-75 JEC SPR-16266
; FIX MESSAGE THAT BEGINS WITH " SO IT DOESN'T GO TO CTY.
; 412 30-JUN-75 JEC SPR-16175
; FIX CALCULATION OF POINTER FOR UNSTRING WHEN DELIMITER IS "ALL".
; MARCH 12, 1975 ADDITION OF SUSPC, SUSPC1 SUBROUTINES TO
; RESET FOR THE PURPOSE OF COMPUTING THE SPACE REQUIRED BY
; SIMULTANEOUS UPDATE, AND GETTING IT. ALSO ADDITION OF THE
; CALL TO THESE SUBROUTINES IN RESET. GIL STEIL
; 16-JAN-75 /ACK 1. CHANGE REFERENCE TO PARAMETER FILE
; LBLPRM TO REFERENCE UNIVERSAL
; FILE LBLPRM.
; 2. ADD CODE FOR SETTING UP THE PUSH DOWN
; LIST WITH THE VALUE SUPPLIED BY
; THE USER WHEN HE COMPILED THE
; PROGRAM
;********** VERSION 7A RELEASE **********
; EDIT 411 MAKE SURE LPT DEVICE DOES NOT CAUSE "ILLEGAL MODE" MONITOR MESSAGE AT RESET TIME.
; ALSO FIX RECOVERY FROM "EOF FOUND INSTEAD OF A LABEL".
; EDIT 410 PUT OUT "$" IN MESSAGE TO TRY ANOTHER MAG TAPE SO OPERATOR SEES THE
; MESSAGE, WHEN THE JOB IS RUNNING UNDER BATCH
; SPR 15662
; EDIT 407 IF POSSIBLE OUTPUT PHYSICAL DEVICE NAME
; AS WELL AS LOGICAL DEVICE NAME- FOR DEVICE MESSAGES
; SPR 15184
; EDIT 406 FIX SORT RELEASE LENGTH CALCULATION SO WORD SIZE AGREES WITH INTERNAL RECORD MODE
; SPR 15189.
; EDIT 405 SET UP REF I12 FOR ISAM FILES AT MSVID FOR FILE VALUE OF ID PRINTOUT.
; EDIT 404 IN LINE.MAC FIX SPACING FOR RPT WRITER
; SPR 14927
; EDIT 403 PUT IN SIRUS CODE AND TRAILING BLANK SUPPRESSION (SWITCH OPTION)
; EDIT 402 FIX CORE PROBLEM IN CSORT; FOR .JBFF VS .JBREL
; EDIT 401 FIX EDIT SO THAT ZERO SUPPRESSION NO LONGER HAPPENS AFTER A 9'S FIELD IS SEEN
; SPR 14617
; EDIT 400 FIX COBFUN SO THAT CHANNEL 0 IS OBTAINED LAST
; EDIT 377 FIX ISAM BUFFER PROBLEM IF ISAM FILE IS
; SHARED AREA (BUFFER) WITH ANY OTHER FILE.
; EDIT 376 GIVE A MEANINFUL ERROR MSG IF UNEXPECTED EOF ON ISAM IDX FILE IS SEEN
; SPR 14453
; EDIT 375 ADD TO EDIT 371- IF ISAM FILE OPEN FOR INPUT ALLOW
; FD > OR = TO ISAM MAX REC SIZE- AND IF FILE OPEN FOR OUTPUT ALLOW
; FD < OR = TO ISAM MAX REC SIZE.
; EDIT 374 FIX TEST FOR OPTIONAL ISAM FILE AT RESET TIME
; EDIT 373 FIX UP CLOSE WITH DELETE FOR DTA FILES.
; EDIT 372 CORRECT BLOCK FACTOR CALC FOR ASCII NON-ISAM FILES
; EDIT 371 CHECK THAT USERS MAX REC DESC SAME AS ISAM MAXREC PARM.
; SPR 13772
;EDIT 370 SEQUENTIAL READING OF AN ISAM FILE MAY OCCASIONALLY
; MISS SEVERAL RECORDS. THE PROBLEM OCCURS WHEN THE
; SYMBOLIC KEY IS A NUMERIC DISPLAY ITEM AND A VERSION
; NUMBER ERROR OCCURS.
;EDIT 343 THROUGH 367 ARE RESERVED FOR DEVELOPMENT
;********* VERSION 7 RELEASE **********
;EDIT 347 FIX STRING TO SPACE FILL EVEN IF NO UNSTRING
;EDIT 346 CBLIO - LIBIMP - CSORT
; MAKE OVERLAYS WORK. CHECK THAT NO IO IS DONE IN AN
; OVERLAY. WHEN ALLOCATING ISAM BUFFER SPACE BE SURE
; YOU DON'T OVERLAP THE OVERLAY AREA, GIVE ERROR MESSAGE.
;EDIT 345 RE-ADJUST SUBROUTINES DISPATCH TABLE SIZE FOR MCS
;EDIT 344 FIX MEMORY MANAGEMENT BUG IN CSORT
;EDIT 343 THIS FIX PREVENTS AN EXTRA BLOCK FROM BEING APPENDED TO
; A BINNARY FILE WHEN THE OUTPUT DEVICE IS A DTA (QAR-40)
;EDIT 342 MAKE EDIT 333 WORK FOR PROGRAMS WO/R SWITCH
; AND MAKE CHN 0 THE LAST ONE USED (FOR RERUN)
; CHANGES TO OVRLAY.MAC AND COBRG OF COMPILER
; ALSO REQUIRES COBST ROUTINE IN LIBOL
;EDIT 341 FIX POSITIONING ; MULTI-FILE LABELLED REELS W/NO
; POSITION CLAUSES
;EDIT 340 UPDATE JOBDAT SYMBOLS, CHANGES IN CSORT,UUO
;EDIT 337 FIX IN ACCEPT, NOT IN CBLIO, SEE JC
;EDIT 336 FIX FILE POSITIONING FOR MULTI-FILE TAPES
;EDIT 335 FIX GARBAGE IN RECORD W/VARIABLE LENGTH ISAM RECS
;EDIT 334 NOT IN CBLIO. JOHN DID EM
;EDIT 333 GET OVERLAY FILE FROM SAME PLACE AS MAIN PROGRAM
;EDIT 332 HANDLE VARIABLE LENGTH RECORDS FOR STAND ALONE SORT
;EDIT 330 FIX READING FROM NUL DEVICE SO THAT CBLIO DOESN'T CONFUSE IT WITH MTA
;EDIT 327 FIX STD LABELS FOR MTA WHEN READING > REEL 9
;EDIT 326 CHANGED CHTAB SO THAT 173 TO 20(ZERO) AND 175 TO 32 (:)
; WHEN READING ASCII FILE TO SIXBIT RECORD JEC
;EDIT 325 FIX SPACING AND REPORT CODE FOR REPORT GEN IN LINE.325 JEC 4/5/74
;EDIT 324 FIX APPENDING TO RANDOM ACCESS FILES READ TO END
;EDIT 323 DONT DO ENTER WHEN LOOKUP OF ISAM DATA FILE FAILS
;EDIT 322 FIX APPENDING OF RECORDS FOR SEQUENTIAL I/O
;EDIT 321 LIBOL REFUSES TO TAKE A RERUN DUMP IF A FILE IS ASSIGNED
; TO THE NULL DEVICE
;EDIT 320 ISAM - "MEM-PRO-VIO..." WHEN ZEROING FREE CORE AT UDIF11
;EDIT 317 MOVE THE TEST FOR EBCDIC FILES INTO THE MAIN LOOP
;EDIT 316 FIXES "ADDRESS CHECK..." WHEN SORT FILE SHARES SAME BUFFER AREA
;EDIT 315 FIX TO EDIT 301 ILG 1-FEB-74
;EDIT 314 *CSORT* PREFIX "?" TO "ERROR IN SORT I-O" MESSAGE
;EDIT 313 *CSORT* FIX REDUNDANT "RECORDS SORTED"
;EDIT 312 IF "ILL-MEM-REF" IN RSTLNK ROUTINE TELL USER HE MAY HAVE LOADED A MACRO ROUTINE IN PLACE OF COBOL SUBROUTINE
;EDIT 311 ISAM - "MEMORY PROTECTION VIOLATION" WHEN WRITING AFTER SPLITING THE TOP INDEX BLOCK
;EDIT 310 ISAM - "?KEYS OUT OF ORDER" CAUSED BY TESTING THE WRONG FLAG WORD
;EDIT 307 ISAM FILE READER GETS "VERSION NUMBER DISCREPANCY" WHEN A WRITER CREATES A NEW INDEX LEVEL
;EDIT 306 ISAM - OPNI03 ASSUMES A 200 WORD BUFFER SIZE BUT IT MAY BE LARGER
;EDIT 305 CHANGE "NOT A LEGAL SIXBIT FILE" ERROR MS TO INDICATE THAT INCORRECT BLOCKING FACTOR COULD BE CAUSE.
;EDIT 304 CORRECT VALUE OF ID AS GIVEN AFTER LOOKUP OR ENTER FAILS
;EDIT 303 FIX TO REPORT-WRITER
;EDIT 302 CORRECT MAG-TAPE POSITION AFTER READING LABELLED FILE
;EDIT 301 DO AN ENTER ON NON-DIRECTORY DEVICES FOR DIRECT,LPTSPL,ETC.
;EDIT 300 HANDLE NULLS IN ASCII RANDOM FILES CORRECTLY
;EDIT 277 PRECEDE ALL ERROR MESSAGES HAVING TO DO WITH POSSIBLE WRONG REELS OR OPTIONAL FILES WITH "$"
;EDIT 276 DUPLICATE ISAM RECORDS IF DATA MODE DIFFERS BTWN RECORD AND DATA FILE
;EDIT 275 CODE TO CORRECT LOW-VALUES READ FOR ISAM AFTER INVALID KEY PATH TAKEN
;EDIT 274 CODE TO SUPPORT THE DATE75 FORMAT I.E. 15 BIT WIDE DATES
;EDIT 273 FIRST RANDOM READ WITH AN ACTUAL KEY POINTING BEYOND THE "EOF" DOES NOT TAKE THE INVALID KEY RETURN
;EDIT 272 TYPE THE VERSION # NOT JUST EDIT # WITH ERROR MESSAGES
;EDIT 271 FIXES "VERSION NUMBER DISCREPANCY..." WHEN MORE THAN ONE SECTOR PER LOGICAL BLOCK
;EDIT 270 STOPS "ILL-UUO-AT-PC..." WHEN TYPING OUT LIBOL ERROR MESSAGE
;EDIT 267 CHANGE GETCH. ROUTINE SO ^U WILL RUBOUT TYPED AHEAD CHARACTERS
SUBTTL PICK UP UNIVERSALS AND SET UP JOBDAT.
IFE %%RPG,<
SEARCH LBLPRM ;DEFINE PARAMETERS.
%%LBLP==:%%LBLP
>
IFN %%RPG,<
SEARCH RPGPRM, RPGUNV
>
SEARCH COMUNI
%%COMU==:%%COMU
INFIX%
ISAM==:ISAM
EBCMP.==:EBCMP.
SEARCH FTDEFS ;FILE-TABLE DEFINITIONS
%%FTDF==:%%FTDF
IFE %%RPG,<
ENTRY C.RSET ;MAKE SURE WE GET LOADED.
LOC 124 ;.JBREN
EXP RENDP ;TO FORCE A DUMP.
VERWHO==0
VERMJR==10
VERMNR==0
VEREDT==EDIT
VERSION==BYTE(3)VERWHO(9)VERMJR(6)VERMNR(18)VEREDT
PURGE VERWHO,VERMJR,VERMNR,VEREDT
LOC 137 ;.JBVER
EXP VERSION
VERSION==<VERSION>B53&77777 ;FOR LATER REFERENCE.
> ; END OF IFE %%RPG
IFNDEF EBCLBL,<EBCLBL=0>
IFNDEF TOPS20,<TOPS20==0> ; JSYS SWITCH
IFNDEF SUPPTB,<SUPPTB==0> ; [403] SUPPRESS TRAILING BLANKS ON OUTPUT ASCII FILES.
IFNDEF EBCMP.,<EBCMP.==0>
HISEG
SUBTTL CONSTANTS
AC0==0 ;AC ASSIGNMENTS
AC1==1
AC2==2
AC3==3
AC4==4
AC5==5
AC6==6
FLG==7
AC10==10
AC11==11
C==11
AC12==12
I12==12
AC13==13
LVL==13
AC14==14
FLG1==14
AC15==15
AC16==16
I16==16
PP==17
REPEAT 0,< ;FLAGS IN LEFT SIDE OF "F.WFLG(I16)" BEFORE RESET
400000==400000 ;VARIABLE LENGTH EBCDIC RECORDS
NONSTD==100000 ;NON STANDARD LABELS
STNDRD==40000 ;STANDARD LABELS
OPNIO==4000 ;FILE IS AN INPUT/OUTPUT FILE
BIT 7-9 ;0 = SIXBIT DEVICE DATA MODE
;1 = BINARY
;2 = ASCII
;3 = EBCDIC
;4 = ASCII-8
;5-7 NOT USED
RRUNER==200 ;RERUN DUMP AT END-OF-REEL
RRUNRC==100 ;RERUN DUMP VIA RECORD-COUNT
FILOPT==20 ;OPTIONAL FILE
BIT 14-15 ;0 = SIXBIT CORE DATA MODE
;1 = BINARY
;2 = ASCII
;3 = EBCDIC
BIT 16-17 ;0 = SEQUENTIAL FILE
;1 = RANDOM FILE
;2 = INDEXED-SEQ FILE
;3 = NOT USED
>
HUF==1
LOCK==2
;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.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.FIDX==^D10000 ;ISAM INDEX FILE
E.FIDA==^D20000 ;ISAM DATA FILE
E.FSEQ==^D30000 ;SEQUENTIAL FILE
E.FRAN==^D40000 ;RANDOM 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 IBCDIC
DDMBIN==40000 ;DEVICE DATA MODE IS BINARY
OPNIN==20000 ;FILE IS OPEN FOR INPUT
OPNOUT==10000 ;FILE IS OPEN FOR OUTPUT
OPNIO==4000 ;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
F1CLR==3777 ; THESE FLAGS ARE CLEARED AT CLOSE TIME
FOPERR==2 ; FILOP.UUO FAILED
IFN ISAM,<
NOTEST==2000 ;SKIPE THE CONVERSION TEST AT ADJKEY [EDIT#276]
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
>
;FLAGS IN LEFT SIDE OF AC16 FOR DURATION OF CURRENT COBOL UUO
WADV==400000
WRITE==200000
READ==100000
OPEN==40000
CLOSEF==20000 ;EOF
CLOSER==10000 ;EOV
CLOSEB==4000 ;HDR
RERIT==10 ;ISAM REWRITE
DELET==4 ;ISAM DELETE
SLURP==2 ;WRITE REEL CHANGE, RESTORE THE RECORD AREA
MTAEOT==1 ;END-OF-TAPE
BUFLOC==4000 ;BUFFER LOCATION HAS BEEN ASSIGNED, LEFT-HALF OF 5(I16)
SRTFIL==2000 ;[316];THIS IS A SORT FILE, LEFT-HALF OF 5(I16)
OEUP==4000 ;OPEN ERROR USE PROCEDURE - ENTER ERROR FILE BEING MODIFIED, BIT 6 OF 22(I16)
SASCII==1 ; REQUEST FOR STANDARD ASCII, IN D.RFLG
TAPOP.==CALLI 154 ; FOR TU70'S 1600 BPI AND STANDARD ASCII
.TFKTP==1002 ; FUNCT TO GET CONTROLER TYPE
.TC10C==2 ; CONTROLLER FOR A TU43
.TX01==3 ; CONTROLLER FOR A TU70
.TM02==4 ; CONTROLLER FOR A TU16
.TFMOD==2007 ; FUNCT TO SET STANDARD ASCII MODE
.TFM8B==2 ; CODE FOR INDUSTRY-COMPATIBLE
.TFM7B==4 ; CODE FOR STANDARD ASCII
.TFSDN==2001 ; FUNCT TO SET DENSITY
.TFGDN==1001 ; FUNCT TO GET DENSITY
FILOP.==CALLI 155 ; FOR SIMULTANEOUS UPDATE
;CONSTANTS FOR EXTENDED LOOKUP BLOCK
.RBPPN==1
.RBNAM==2
.RBEXT==3
.RBPRV==4
.RBSIZ==5
R.IOWD==0 ; IOWRD FOR RANDOM/IO FILES
R.TERM==1 ; IOWRD TERMINATOR
R.BPNR==2 ; BYTE POINTER TO NEXT RECORD IN BUFFER
R.BPLR==3 ; LAST RECORD
R.BPFR==4 ; FIRST RECORD
R.DATA==6 ; BUFFER HAS ACTIVE DATA TO BE WRITTEN OUT
R.WRIT==7 ; LAST IO OPERATION FOR THIS FILE WAS A WRITE
R.FLMT==10 ; AOBJ POINTER TO FILE LIMITS
SUBTTL EXTERNALS.
EXTERNAL LIBIMP ;CAUSES LIBREL ( LIBOL.LOW) TO BE LOADED FOR /R
EXTERNAL INTBLK,.JBINT ; [414]
EXTERNAL IIN,IOUT,ISETI,ISETO,ICLOS,IRELE,IGETS,IWAIT,IRNAM
EXTERNAL MWAIT.,MREW.,MREWU.,MBSPR.,MBSPF.,MADVR.,MADVF.,MWEOF.,MTIND.
EXTERNAL SOBOT.,SZBOT.,SZEOF.,SZEOT.
EXTERNAL UOPEN.,UENTR.,ULKUP.,UOBUF.,UIBUF.,UCLOS.,URELE.,USETI.
EXTERNAL USETO.,UOUT.,UIN.,USETS.,UGETS.,UWAIT.,USEEK.,URNAM.
EXTERNAL UOCAL.,OPNCH.,UOBLK.,NRSAV.
EXTERNAL UEBLK.,ULBLK.,TTOBP.,TTOBC.,TTOBF.,STDLB.
EXTERNAL REDMP.,TEMP.,TEMP.1,JSARR.,TEMP.2,AINFO.,OVRBF.,FLDCT.,OVRIX.
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]
EXTERNAL RUN.TM ;[333]
EXTERNAL PUSHL.,CB.DDT,LEVEL.,%F.PTR,SBPSA.
IFE %%RPG,<
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
IFE %%RPG,<
EXTERN SU.FRF ;FAKE READ FLAG
INTERN FAKER.,IGSS,RANFIL,IDXFIL,E.VRET,D.RP,D.CBN,D.CN,D.BL ;SIMULTANEOUS UPDATE
INTERN DSPLY.
>
EXTERN .JBSA,.JBFF,.JBREL,.JB41,.JBAPR,.JBTPC,.JBCNI,.JBVER,.JBDA,.JBOPC,.JBREN
EXTERN .JBOPS
INTERN C.CLOS,DOPFS.,C.END,GETCH.,DSPL1.,MSOUT.,C.OPEN,OUTCH.
INTERN OUT6B.,OUTBF.,READ.,RSTAB.,SEEK.,STOPR.,C.STOP,TODAY.,TRAP.,WRITE.,WADV.,WRPW.
INTERN GOTO.,KILL.,PPOUT.,ULOSE.
EXTERNAL RET.1,RET.2,RET.3,UUO.
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.
IFE %%RPG,<
EXTERN RN.PPN,RN.DEV,RN.NAM,OVRFN.,TRAC1.,SEGNO.
>
IFN %%RPG,<
INTERN OUTBF1, WAD2, SETCN.
>
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
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 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
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
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
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
MLON
IFE %%RPG,<
LIBSW.: SWSET% ;LIBOL ASSEMBLY SWITCHES
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.
CALLI AC11,27 ;[346]GET THE RUNTIME.
MOVEM AC11,RUN.TM ;[346]SAVE IT.
HRRZ AC1,.JBSA ;[START.]
MOVEM AC1,JSARR. ;SAVE FOR RRDMP
HRRZ AC1,.JBFF ;TO-1
CAMG AC1,.JBREL ;SKIP ILL-MEM-REF
SETZM (AC1) ;ZERO WORD
HRL AC1,AC1 ;FROM,,TO-1
ADDI AC1,1 ;FROM,,TO
HRRZ AC2,.JBREL ;UNTIL
CAIL AC2,(AC1) ;SKIP ILL-MEM-REF IF .JBFF = .JBREL
BLT AC1,(AC2) ;ZERO FREE COR
RESET1: MOVEI AC0,[TTCALL 3,[ASCIZ/COBOL PROGRAMS MAY ONLY BE STARTED THROUGH
USE OF "GET AND ST" OR "RUN" MONITOR COMMANDS/]
CALLI 12] ;EXIT
HRRM AC0,.JBSA
MOVE PP,[PUSHJ PP,UUO.]
MOVEM PP,41
HLRZ PP,.JBOPS ;START OF IMPURE AREA
RSET1A: 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 SORT
MOVNI PP, (AC10) ;0,,-LENGTH
HRL PP, .JBFF ;START-LOC,,-LENGTH
MOVSS PP, PP ;POINTER IS SET UP.
MOVEI AC10, 1(AC10) ;LENGTH+1
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.
CALLI AC10, 11 ;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,230000 ;[312];PDLOV - MPVIO - NXM
CALLI AC0,16 ;[312];APRENB UUO
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
PUSHJ PP,SETOVR ;SET UP OVERLAY FILE
PUSHJ PP,RSTAB. ;ASSIGN THE BUFFER AREA
SKIPE KEYCV.## ;WERE WE CALLED BY SORT?
JRST 1(AC14) ;YES, RETURN.
HRRZ AC10,COBSW. ;GET COMPILER ASSEMBLY SWITCHES
HRRZ AC3,LIBSW. ;GET LIBOL ASS-SWITCHES
CAME AC10,AC3 ;THE SAME?
TTCALL 3,[ASCIZ /% COBOL-LIBOL ASSEMBLY SWITCHES MISMATCHED
/]
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
RSTL10: HRRZ AC5,(AC1) ;[346] CHECK TO SEE IF THIS SUBROUTINE
JUMPN AC5,RSTL30 ; IS IN AN LINK-10 OVERLAY AREA.
;; ((AC1)) = SKIPA 0,0 == IT ISN'T
;; ((AC1)) = JSP 1,MUMBLE == IT IS.
MOVE AC1,1(AC1) ;ADDRES 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
JUMPE AC4,RSTL12 ;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
RSTL30: SKIPE 1(AC2) ;ANY MORE SUBPRGMS?
AOJA AC2,RSTL20 ;INCREMENT POINTER AND TRY AGAIN
RSTLNX: POPJ PP, ;[312];NO--DONE.
> ; END OF IFE %%RPG
;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
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
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?
IFE ISAM,< JRST RSTNFL ; [377] YES-NEXT FILE >
IFN ISAM,< JRST RSTSAL ; [377] YES- SET UP SAVE AREA FOR ISAM FILES >
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/
CALLI AC3,4 ;DEVCHR UUO
TLNN AC3,140610 ;SKIP IF A LPT,TTY,PTP,PTR,CDP, OR CDR
JRST RSTDE0 ;
TLNN AC3,40000 ; [414] LPT?
JRST RSTDV1 ; [414] NO
MOVE AC12,(AC13) ; [414] LPT - GET NAME
DEVTYP AC12, ; [414] SEE IF REAL LPT.
JRST RSTDV1 ; [414] CAN'T, SKIP THIS.
TLNE AC12,20 ; [414] IF SPOOLED SKIP THIS.
JRST RSTDV1 ; [414] IT IS
PUSHJ PP,INTINT ; [414] REAL LPT SET UP TRAPPING.
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 ;
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
HRLM AC12,D.BL(I16) ;SET BUFFER LOCATION
MOVE AC12,(AC13) ;SIXBIT /DEVNAM/
MOVEM AC12,UOBLK.+1 ;FOR THE INIT BLOCK
HRLZI AC12,D.OBH(I16) ;LOC OF OBUF HDR
TLNE FLG,OPNIO ;SKIP IF NOT IO
HRRI AC12,D.IBH(I16) ;LOC OF IBUF HDR
MOVEM AC12,UOBLK.+2 ;INIT BLOCK
IFN ISAM,<
MOVEI AC1,17 ;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
TLNN AC3,20 ;SKIP IF A MTA
TLNE FLG,RANFIL+OPNIO ;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,OPNIO ;THE
XCT UIBUF. ;BUFFERS **************
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
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,
IFN ISAM,<
; THIS ROUTINE GOES ALL FILES IN A SAME RECORD AREA CHAIN TO
;SET UP A SAVE AREA FOR ISAM FILES. THIS SAVE AREA WILL BE USED TO SAVE
;THE SECTION OF THE SHARED BUFFER AREA THAT ISAM FILE EXPECTS TO
;BE TRUE VALUES
RSTSAL: SKIPE KEYCV. ; [377] SKIP THIS IS HERE ON SORT
JRST RSTNFL ; [377]
PUSH PP,AC16 ; [377] SAVE CURRENT FILE TABLE ADR
MOVE AC12,TEMP. ; [377] UPDATE .JBFF
ADDB AC12,.JBFF ; [377]
SETZM TEMP. ; [377] CLEAR BUFFER SIZE
RSTSL1: MOVE FLG,F.WFLG(I16) ; [377] GET FILE PARAMS
TLNN FLG,IDXFIL ; [377] ISAM FILE ?
JRST RSTLP ; [377] NO- GET NEXT FILE
HRRZ AC2,D.IBL(I16) ; [377] SAVE AREA ALREADY SET UP?
JUMPN AC2,RSTLP ; [377] IF SO, GO GET NEXT FILE
HRRZ AC12,.JBFF ; [377] GET FREE CORE AREA
HRRM AC12,D.IBL(I16) ; [377] SET START OF SAVE AREA TO .JBFF
MOVEI AC0,ISMCLR+1 ; [377] AMOUNT OF SPACE FOR SAVE ARE
PUSHJ PP,GETSPC ; [377] GET CORE SPACE
JRST GETSPK ; [377] NO CORE- QUIT
RSTLP: HLRZ AC12,F.LSBA(I16) ; [377] GET NEXT FILE IN SAME AREA CHAIN
JUMPE AC12,RSTSL2 ; [377] NO MORE
CAMN AC12,(PP) ; [377] SEE IF WE WENT ALL THRU CHAIN
JRST RSTSL2 ; [377] YES ALL DONE
MOVEM AC12,AC16 ; [377] SET UP NEXT FILE IN SAME AREA CHAIN
JRST RSTSL1 ; [377] DO THIS FILE
RSTSL2: POP PP,AC16 ; [377] GET BACK FIRST FILE IN CHAIN
JRST RSTNFL ; [377] GO ON TO NEXT FILE TABLE
> ; [377] END IFN ISAM
;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
TLNN AC3,20 ; AND DEVICE IS A MTA
JRST RSTD40 ;
MOVEI AC5,1 ; THEN BLK-FTR DEFAULTS TO 1
DPB AC5,F.BBKF ;
RSTD40: PUSHJ PP,OPNWPB ;AC10= WODRS PER LOGICAL BLOCK
JUMPE AC5,RSTDE7 ;JUMP IF BLOCKING FACTOR IS 0
ADDI AC10,3 ; PLUS 3 FOR BOOKEEPING WORDS
TLNN AC3,20 ;SKIP IF A MTA
JRST RSTDE6 ;JUMP ITS NOT A MTA
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
;IFN EBCDIC,<
TLNN AC3,20 ; DEVICE A MTA?
JRST RSTD42 ; NO
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?
SETOI I12, ; [414] YES ONE BUFFER.
IMULI AC10,2(I12) ;REC TIMES NUMBER OF ALTERNATE BUFFERS
JRST RSTD11 ;
RSTDE6: TLNN AC3,200000 ;SKIP IF DEV IS A DSK
JRST RSTER0 ;COMPLAIN
ADDI AC10,7 ;3+7=12 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: TTCALL 3,[ASCIZ /ONLY DSK MAY BE USED FOR RANDOM, IO OR INDEX-SEQ PROCESSING/]
RSTERR: MOVE AC2,[BYTE (5)10,31,20]
PUSHJ PP,MSOUT.
IFE ISAM,<
RERIT.: TTCALL 3,[ASCIZ /REWRITE ?/]
SKIPA
DELET.: TTCALL 3,[ASCIZ /DELETE ?/]
RSTIDX: TTCALL 3,[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: 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
MOVEI AC0,1 ;USE CHANNEL ONE
MOVEM AC0,ICHAN(I12) ;SAVE IT AWAY
PUSHJ PP,OCPT ;USE TOPS20 COMPT. UUO
JRST [CAME AC1,[0,,600130] ;INVALID SMU ACCESS?
JRST [TTCALL 3,[ASCIZ /RESET TIME /]
JRST OCPERR ]
HRRZI AC0,1B25 ;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 [TTCALL 3,[ASCIZ /RESET TIME /]
JRST OCPERR ]
JRST .+1]
POP PP,AC13 ;RESTORE AC13
MOVE AC3,(AC13) ;GET DEVICE NAME
CALLI AC3,4 ;RESTORE DEVICE CHARACTERISTICS
>
MOVEI AC0,STABL ;
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 AC12,1+ISPB(AC1) ;INDEX SECTORS / BLK
JRST RSTIER ;
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
TTCALL 3,[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) ; GET FLG1 PARMS [377]
TLNN AC1,FILOPT ;OPTIONAL FILE? [374]
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
TTCALL 3,[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) ;
CAMLE AC2,MXBF ;
MOVEM AC2,MXBF ;
LDB AC6,KY.TP ; GET KEY TYPE
JUMPN AC6,RSTID2 ;BRANCH IF NON-NUMERIC-DISPLAY
MOVE AC4,1+IESIZ(AC1) ;INDEX ENTRY BLOCK SIZE
SUBI AC4,1 ;-2 HDR WRDS, +1 WRD FOR WRAP-AROUND
IMULI AC4,3 ;RESERVE 3 KEY AREAS
JRST RSTID3 ;
RSTID2: MOVEI AC4,6 ;1+1*3
TRNN AC6,1 ;ODD = 1 WRD, EVEN = 2 WRDS
MOVEI AC4,9 ;2+1*3
RSTID3: ADDI AC12,2(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
CALLI AC2,4 ;DEVCHR
TLNE AC2,200000 ;DATA FILE
TLNN AC3,200000 ;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
TTCALL 3,[ASCIZ /DATA-MODE DISCREPANCY/]
MOVE AC2,[BYTE (5)10,31,20,4]
JRST MSOUT. ;
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
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
SETZM UOBLK. ;
JRST RSTDE5 ;RETURN
RSTIER: XCT UGETS. ;INPUT ERROR DURING RESET UUO
TRNE AC2,020000 ;[376] EOF?
TTCALL 3,[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
CALLI AC0,11 ;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: TTCALL 3,[ASCIZ/INSUFICIENT CORE FOR BUFFER REQUIREMENTS/]
POPJ PP,
GETSPK: PUSHJ PP,GETSP9
JRST KILL
;SUBROUTINE TO SET UP OVERLAY FILE
IFE %%RPG,<
SETOVR: SKIPN AC1,OVRFN. ;ANY FILE TO BE OPENED
POPJ PP, ;NO--RETURN
HRLZI AC0,577774 ;[342]TURN OFF CHAN 1
ANDM AC0,OPNCH. ;DOIT
HRROI AC0,-1 ;DSK = -1
SKIPN AC3,RN.DEV ;[333]IF DEVICE SPECIFIED, GET IT
HRLZI AC3,(SIXBIT /DSK/) ;
SETOV1: MOVEI AC2,14+1B30 ;SET UP DEVICE
HRRZI AC4,OVRBF. ;
OPEN 1,AC2 ;[342]INIT
JRST SETOV4 ;
MOVSI AC2,(SIXBIT "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
MOVEI AC1,OVRIX. ;
PUSHJ PP,SETOV2 ;
MOVEI AC1,OVRIX.+200 ;
SETOV2: IN 1, ;[342]
SKIPA AC2,OVRBF. ;
JRST SETOV6 ;
MOVSI AC2,2(AC2) ;
HRR AC2,AC1 ;
BLT AC2,177(AC1) ;
POPJ PP,
SETOV4: TTCALL 3,[ASCIZ "CANNOT INITIALIZE OVERLAY DEVICE"]
JRST KILL
SETOV5: HRLZI AC3,(SIXBIT /SYS/) ;TRY SYS IF DSK FAILS
AOJE SETOV1 ;
TTCALL 3,[ASCIZ "CANNOT FIND OVERLAY FILE"]
JRST KILL
SETOV6: TTCALL 3,[ASCIZ "INPUT ERROR ON OVERLAY DEVICE"]
JRST KILL
> ; END OF IFE %%RPG
;ROUTINE TO REORGANIZE THE FLAGS
RSTFLG: MOVE FLG,F.WFLG(I16) ;GET FLAGS
HRLZI AC15,4300 ;
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 ;
TLNE FLG,20 ;FILOPT?
TRO AC15,FILOPT ;
TLNE FLG,100000 ;NONSTD?
TRO AC15,NONSTD ;
TLNE FLG,40000 ;STNDRD?
TRO AC15,STNDRD ;
TLNN AC15,DDMEBC ;ONLY EBCDIC HAS VAR-LEN RECORDS
JRST RSTFL1 ;
TLNE FLG,400000 ;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
;**; BEFORE TRAP. [414]
; FOR REAL PRINTER ON-LINE.
;
; ERROR INTERCEPT.
INTLOC: PUSH PP,INTBLK+2 ; [414] SAVE RETURN ADDRESS.
PUSH PP,AC13 ; [414] SAVE AC13
SETZM INTBLK+2 ; [414]
MOVEI AC13,^D30000 ; [414] SLEEP FOR 1/2 MIN.
HIBER AC13, ; [414]
JFCL ; [414]
POP PP,AC13 ; [414] RESTORE AC13
POPJ PP, ; [414] RETURN TO PROGRAM TO RETRY.
;
;INITIALIZE INTERRUPT.
;
INTINT: PUSH PP,AC13 ; [414] SAVE
MOVEI AC13,INTBLK ; [414] SAVE LOCATION OF INTERRUPT BLOCK
MOVEM AC13,.JBINT ; [414] IN JOBDAT.
MOVEI AC13,INTLOC ; [414] SAVE INTERRUPT ADDRESS
HRLI AC13,4 ; [414] AND ITS LENGTH
MOVEM AC13,INTBLK ; [414] INTO INTERRUPT BLOCK
MOVEI AC13,1 ; [414] SET FOR OFFLINE DEVICE.
MOVEM AC13,INTBLK+1 ; [414]
SETZM INTBLK+2 ; [414] CLEAR BLOCK
SETZM INTBLK+3 ; [414]
POP PP,AC13 ; [414] RESTORE AC13
POPJ PP, ; [414] RETURN.
;TRAP INTERUPT ROUTINE
TRAP.: MOVE AC0,.JBCNI ;APR STATUS
TRNE AC0,20000
TTCALL 3,[ASCIZ/MEMORY PROTECTION VIOLATION AT USER LOC /]
TRNE AC0,10000
TTCALL 3,[ASCIZ/NON-EX-MEM REQUEST AT USER LOC /]
TRNE AC0,200000
JRST TRAP1 ;PDLOV
TRAP0: HRLO AC12,.JBTPC ;THE GUILTY LOCATION
PUSHJ PP,PPOUT4 ;OUTPUT THE LOC
IFE %%RPG,<
HRRZ AC0,.JBTPC ;[312];SEE IF ERROR IS
CAIL AC0,RSTLNK ;[312]; IN RSTLNK
CAIL AC0,RSTLNX ;[312]; ROUTINE.
JRST KILL ;[312];NO
TTCALL 3,[ASCIZ /$FAILING ROUTINE IS RSTLNK IN CBLIO
MACRO ROUTINE LOADED IN PLACE OF COBOL SUBROUTINE?/]
>
JRST KILL ;AND KILL
TRAP1: TTCALL 3,[ASCIZ/PUSH-DOWN-LIST OVERFLOW AT /]
JRST TRAP0
SRTER.:: TTCALL 3,[ASCIZ /YOU MUST RECOMPILE TO USE THE NEW SORT/]
JRST KILL.
;ULOSE. IS THE ERROR EXIT FOR A UUO CALL TO A ROUTINE
;THAT WAS NOT LOADED. THE RUN IS TERMINATED VIA KILL
ULOSE.: TTCALL 3,[ASCIZ /ENCOUNTERED A UUOCALL FOR A ROUTINE THAT WAS NOT LOADED
/]
SKIPA ;TO KILL
;GOTO IS THE ERROR EXIT FOR UNALTERED "GOTO"
;STATEMENTS WHICH DID NOT PROVIDE AN OBJECT PARAGRAPH NAME.
GOTO.: TTCALL 3,[ASCIZ /ENCOUNTERED AN UNALTERED GOTO WITH NO DESTINATION
/]
;KILL TYPES OUT THE LOCATION OF THE LAST COBOL UUO,
;STOPS ALL IO AND EXITS TO THE MONITOR.
KILL: PUSHJ PP,TYPSTS ;TYPE ERROR-NUMBER, BLOCK # + REC #
KILL.: PUSHJ PP,VEROUT ;TYPE THE VERSION NUMBER
TTCALL 3,[ASCIZ /
?/]
IFE %%RPG,<
SKIPE TRAC1. ;IS THIS A PRODUCTION PROGRAM (I.E. /P)? [EDIT#270]
PUSHJ PP,@TRAC1. ;NO, CALL BTRAC. IN TRACE ROUTINE
>
PUSHJ PP,PPOUT. ;TYPE THE LOCATION OF LAST COBOL VERB
JRST STOPR2
;TYPE OUT SOME ERROR INFORMATION
TYPSTS: TTCALL 3,[ASCIZ /
$ ERROR-NUMBER = /]
TYPST1: MOVE AC0,FS.EN ;ERROR-NUMBER
PUSHJ PP,PUTDEC ;TYPE IT
MOVE AC0,FS.BN ;BLOCK-NUMBER
JUMPE AC0,TYPST2 ;
TTCALL 3,[ASCIZ / BLOCK-NUMBER = /]
PUSHJ PP,PUTDEC ;
TYPST2: MOVE AC0,FS.RN ;RECORD-NUMBER
JUMPE AC0,RET.1 ;
TTCALL 3,[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
TLNE FLG,OPNIN+OPNOUT; IF THE FILE IS OPEN
PUSHJ PP,C.CLOS ; CLOSE IT
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
TTCALL 3,[ASCIZ /% /] ;
PUSHJ PP,PUTDEC ; TYPE NUMBER
TTCALL 3,[ASCIZ/ ERRORS IGNORED/]
STOPR3:
IFE %%RPG,<
PUSHJ PP,@HPRT.## ; PRINT HISTORY REPORT IF ANY
>
CALLI 12 ;CALLI EXIT
;TYPE THE VERSION NUMBER "LIBOL N(M)"
VEROUT: SKIPN AC12,.JBVER ;GET VERSION NUMBER
JRST VEROU1 ;EXIT IF NOT THERE
IFE %%RPG,<
TTCALL 3,[ASCIZ /
LIBOL /]
>
IFN %%RPG,<
TTCALL 3,[ASCIZ /
RPGLIB /]
>
MOVEI AC0,4 ;
PUSHJ PP,NUMOUT ;THE VERSION NUMBER
MOVEI AC0,6 ;
HRLZ AC12,.JBVER ;
JUMPE AC12,VEROU1 ;DONE IF NO EDIT NUMBER
MOVEI C,"(" ;
PUSHJ PP,OUTCH. ;
PUSHJ PP,NUMOUT ;THE EDIT NUMBER
MOVEI C,")" ;
PUSHJ PP,OUTCH. ;
VEROU1: JRST DSPL1. ;"CRLF" AND EXIT
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
POPJ PP,
; C.STOP IS CALLED WITH A "PUSHJ PP,C.STOP" AFTER THE OPERATOR
; TYPES "CONTINUE" IT RETURNS TO THE CALLING ROUTINE
C.STOP: TTCALL 3,[ASCIZ /$ TYPE CONTINUE TO PROCEED .../]
CALLI 1,12 ; WAIT FOR CONT
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.:
IFE %%RPG,<
TTCALL 3,[ASCIZ /LAST COBOL VERB CALLED FROM /]
>
IFN %%RPG,<
TTCALL 3,[ASCIZ /Last RPGLIB 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
IFE %%RPG,<
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
TTCALL 3,[ASCIZ/ IN PROGRAM /]
SKIPN AC3,SBPSA. ; SKIP IF ANY SUBPRGMS
JRST PPOUT6 ; NONE
PPOUT5: TTCALL 3,[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
TTCALL 3,[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
TTCALL 3,[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
IFE %%RPG,<
; 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.RRT
ADD AC0,SU.EQT
ADD AC0,SU.EQT
ADD AC0,SU.EQT ;(THERE ARE THREE ENQ/DEQ TABLES)
ADD AC0,SU.FBT
SKIPN AC0
POPJ PP, ;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: TTCALL 3,[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
> ; END OF IFE %%RPG
SUBTTL SEEK-UUO
;A SEEK UUO LOOKS LIKE:
;002240,,ADR ADR = FILE TABLE ADDRESS
;CALL+1: ;POPJ RETURN
SEEK.: 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***
IFE %%RPG,<
;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
MOVEI AC2,EDIT
HRLI AC2,VERSION
MOVEM AC2,.JBVER ; [EDIT#272]
POPJ PP,
> ; END OF IFE %%RPG
SUBTTL DISPLAY-UUO
IFE %%RPG,<
;CALLING SEQUENCE IS PUSHJ PP,DSPLY. WITH THE CALLING UUO IN AC 16.
;THE UUO'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: 17,15,11,7,6,AND 4.
;AC16= ;THE CALLING UUO
;AC15= ;UUO'S OPERAND
;AC6= ;CHARACTER COUNT
;AC4= ;BLANK COUNT
;AC12 ;MUST NOT BE USED
;FOLLOWING BITS ARE IN LEFT HALF OF FLG
BIT6= 4000 ;NUMERIC, SUPPRESS LEADING SPACES AND TABS
BIT7= 2000 ;LAST FIELD, APPEND "CRLF"
DSPLY.: SKIPE TTYOPN ;IS THERE A TTY FILE OPEN?
PUSHJ PP,DSPTO ;YES, DUMP THE BUFFER BEFORE DISPLAYING
MOVE AC15,(I16) ;GET DISPLAY OPERAND
MOVE FLG,AC15 ;SAVE IT FOR THE FLAGS
LDB AC6,DOPFS. ;NUMBER OF CHARS. TO BE DISPLAYED
TLZ AC15,7777 ;
TLO AC15,700 ;(AC15) IS BYTE POINTER TO CHARS.
TLNE FLG,BIT7 ;APPEND CR-LF AT END?
JRST DSPL2 ; YES
ILDB C,AC15 ;GET A CHARACTER.
SKIPE C ;DONT PASS NULLS BUT COUNT THEM
PUSHJ PP,OUTEST ;OUTPUT A CHAR.
SOJG AC6,.-3 ;LOOP IF NOT DONE.
JRST OUTBF. ;DUMP THE BUFFER AND EXIT.
DSPL2: SETZ AC4, ;CLEAR THE BLANK COUNT
DSPL23: ILDB C,AC15 ;GET A CHARACTER
CAIN C,040 ;A BLANK?
AOJA AC4,DSPL21 ; YES
JUMPE AC4,DSPL22 ;JUMP IF NO ACCUMULATED BLANKS
MOVEI C,040 ;OUTPUT BLANKS
PUSHJ PP,OUTEST ;
SOJG AC4,.-2 ;LOOP
LDB C,AC15 ;RESTORE ORIGINAL CHARACTER
DSPL22: SKIPE C ;COUNT NULLS BUT DONT OUTPUT THEM
PUSHJ PP,OUTEST ;OUTPUT THE CHARACTER
DSPL21: SOJG AC6,DSPL23 ;LOOP
> ; end of IFE %%RPG
DSPL1.: MOVEI C,15 ;APPEND CR-LF
PUSHJ PP,OUTCH. ; .
MOVEI C,12 ; .
PUSHJ PP,OUTCH. ; .
JRST OUTBF. ;DUMP BUFFER AND EXIT.
IFE %%RPG,<
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
OUTEST: TLNN FLG,BIT6 ;SUPPRESS LEADING SPACES?
JRST OUTCH. ; NO.
CAIE C,40 ; YES, ARE THERE ANY?
CAIN C,11 ;
POPJ PP, ; YES.
TLZA FLG,BIT6 ; NO, AND NONE FOLLOWING.
> ; END OF IFE %%RPG
OUT6B.: ADDI C,40 ;CONVERT A 6IXBIT CHAR
OUTCH.: IDPB C,TTOBP. ;DEPOSIT CHAR. IN BUFFER.
SOSLE TTOBC. ;DUMP THE BUFFER?
POPJ PP, ; NO.
;OUTPUT A TTY BUFFER. ***POPJ***
OUTBF.: SETZ C, ;ASCIZ TERMINATOR
IDPB C,TTOBP. ;
TTCALL 3,TTOBF. ;DUMP THE BUFFER
OUTBF1: 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
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.: TTCALL 4,C ;INPUT A LINE, FIRST CHAR TO C [EDIT#267]
CAIN C,15
JRST GETCH.
CAIN C,33
JRST GETCH1
CAIG C,14
CAIGE C,12
JRST RET.2
GETCH1: MOVEI C,12
POPJ PP,
SUBTTL OPEN-UUO
;AN OPEN UUO LOOKS LIKE:
;001000,,ADR WHERE ADR = FILE TABLE ADDRESS
;BIT9 =1 OPEN FOR OUTPUT
;BIT10 =1 OPEN FOR INPUT
;BIT11 =1 DON'T REWIND
;BIT12 =0 ALWAYS 0 (VS. 1 = CLOSE)
;CALL+1: POPJ RETURN
;MAKE PRELIMINARY CHECKS: ALREADY OPEN, OPTIONAL FILE PRESENT,
;ANOTHER FILE USING SHARED BUFFER AREA ***OPNDEV***
C.OPEN: TLO AC16,OPEN ;OPEN-UUO
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
HLRZ AC0,F.WDNM(I16) ;[346] CHECK FLAG TO SEE IF THIS
TRNN AC0,4000 ; FILE TABLE HAS BEEN LINKED TO
JRST OOVLER ; THE CHAIN.
TLNN FLG,OPNIN+OPNOUT ;IS THE FILE OPEN?
JRST OPNLOC ;NO
HRLZI AC2,(BYTE (5)10,2,3) ;FCBO,AO.
MOVEI AC0,^D10 ;ERROR NUMBER
JRST OXITER ;ONLY CLOSED FILES MAY BE OPENED
OPNLOC: SETZM D.RP(I16) ;INITIALIZE THE RECORD SEQUENCE NUMBER
MOVE AC5,D.LF(I16) ;
TLNN AC5,LOCK ;SKIP IF THE FILE IS LOCKED
JRST OPNOPT ;
MOVEI AC0,^D11 ;ERROR NUMBER
PUSHJ PP,OXITP ;DOESN'T RETURN IF IGNORING ERRORS
TTCALL 3,[ASCIZ /LOCKED /]
HRLZI AC2,(BYTE(5)10,2,4)
JRST MSOUT. ;EXIT, THE FILE IS LOCKED
OPNOPT: TLNE AC16,400 ;SKIP IF NOT OUTPUT
TLO FLG,OPNOUT ;
TLNE AC16,200 ;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
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
HLL AC4,10(AC4) ;GET THE FLAGS
TLNE AC4,030000 ;SKIP IF ANY FILES ARE NOT OPEN
JRST OPNSB2 ;GIVE AN ERROR MESSAGE
HLRZ AC4,15(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
TTCALL 3,[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
OOVLE2: TTCALL 3,[ASCIZ /IO CANNOT BE DONE FROM AN OVERLAY/] ;[346]
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
;OPNOP+2 [277] IG 22-OCT-73
PUSHJ PP,$SIGN ;OUTPUT "$" FOR .OPERATOR [EDIT#277]
TTCALL 3,[ASCIZ /IS /] ;OPTIONAL FILE PRESENT?
PUSHJ PP,MSFIL.
TTCALL 3,[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
TTCALL 3,[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: TTCALL 11,0 ;CLEAR THE BUFFER
TTCALL 3,[ASCIZ /$ TYPE YES OR NO
/]
YES.NO: MOVE AC5,[POINT 7,[ASCIZ /ES/],]
PUSHJ PP,GETCH.
JRST .-1
CAIE C,"Y"
JRST YESNO2
YESNO1: PUSHJ PP,GETCH.
POPJ PP, ;IS THE "YES" RETURN
ILDB AC4,AC5
JUMPE AC4,RET.1 ;[V10]
CAMN AC4,C
JRST YESNO1
JRST YESNO
YESNO2: MOVE AC5,[POINT 7,[ASCIZ /NO/],]
YESNO3: ILDB AC4,AC5
JUMPE AC4,RET.2 ;[V10]
CAME AC4,C
JRST YESNO
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, ;
;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.
TLNE AC13,40 ;SKIP IF NOT AVAILABLE TO JOB
JRST OPNDE2
MOVE AC2,[BYTE (5)10,2,4,20,15] ;FCBO,DINATTJ.
MOVEI AC0,^D13 ;ERROR NUMBER
JRST OXITER ;COMPLAIN
OPNDE2: TLNN AC13,200000 ;SKIP IF A DSK
TRNN AC13,200000 ;SKIP IF DEV IS INITED
JRST OPNDE6
MOVE AC2,[BYTE (5)10,2,4,20,16] ;FCBO,DIATAF.
MOVEI AC0,^D14 ;ERROR NUMBER
JRST OXITER ;COMPLAIN
OPNDE6: TLNN FLG,OPNIO ;SKIP IF IO IS REQUESTED
JRST OPNDE7 ;NEXT TEST
TLNE AC13,200000 ;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
OPNDE7: TLNE FLG,OPNIN ;SKIP IF NOT AN INPUT REQUEST
TLNE AC13,2 ;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: TLNE FLG,OPNOUT ;SKIP IF NOT AN OUTPUT REQUEST
TLNE AC13,1 ;SKIP IF DEVICE CANNOT DO OUTPUT
JRST OPNCHN ;FIND A FREE CHAN
MOVE AC2,[BYTE (5)10,2,4,20,22]
MOVEI AC0,^D17 ;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
CALLI AC13,4 ;DEVCHR UUO
TLNN FLG,OPNIO+OPNIN ;[330]IF NOT INPUT THEN IGNORE
JRST DEVCH1 ;[330]
TLC AC13,300000 ;[330]IF A DSK AND A CDR
TLCN AC13,300000 ;[330]THEN ITS DEVICE 'NUL'
TLZ AC13,20 ;[330]SO ITS NOT A MAGTAPE
DEVCH1: MOVEM AC13,D.DC(I16) ;[330]SAVE THE CHARACTERISTICS
SKIPE AC13
POPJ PP,
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,14 ;PERHAPS BINARY
TLNE FLG,RANFIL!OPNIO!IDXFIL ;SKIP IF BUFFERED IO
MOVEI AC6,17 ;DUMP MODE
HRRM AC6,UOBLK. ;UOBLK.+1 SET AT DEVCHR
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:>
SKIPN F.WSMU(I16) ; SIMULTANEOUS UPDATE?
JRST OPNC31 ; NO
IFE TOPS20,<
PUSHJ PP,OPNFOP ; YES OPEN FILE VIA FILOP
JRST OFERR ; ERROR RETURN
>; END OF IFE TOPS20
IFN TOPS20,<
PUSHJ PP,OCPT ; OPEN FILE VIA DEC-SYS-20 COMPT.
JRST OCPER ; ERROR RETURN
>; END IFN TOPS20
JRST OPNC41 ;
OPNC31: XCT UOPEN. ;OPEN THE DEVICE ***************
OPNCH4: 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))
TLNE AC13,20 ;SKIP IF NOT A MTA
JUMPN AC5,OPNNSB ;NON STANDARD BUFFER SIZE
IFN ISAM,<
TLNE FLG,IDXFIL ;ISAM ?
JRST OPNIDX ;YES
>
TLNE FLG,OPNIO+RANFIL ;OPNIO=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.
TLNE FLG,OPNIN ;INPUT?
XCT UIBUF. ;**********
TLNE FLG,OPNOUT ;OUTPUT?
XCT UOBUF. ;**********
POP PP,.JBFF ;RESTORE .JBFF
OPNCH2: TLNE AC13,4 ;SKIP IF NON-DIRECTORY DEVICE
TLNE FLG1,STNDRD ;SKIP IF NOT STANDARD LABELS
JRST OPNBSI ;SET THE BYTE SIZE
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.
;SET UP NON-STD MTA BUFFERS (SIZE OF LOGICAL BLOCK). ***OPNCH2***
OPNNSB: 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,400000 ; 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...
JRST OPNCH2 ;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
MOVNM AC10,AC6 ;0,,-N
HRLI AC6,R.FLMT(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
HRRI AC6,1+R.FLMT(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
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
SKIPE F.WSMU(I16) ; SIMULTANEOUS UPDATE?
JRST OPNIX2 ; YES
XCT ULKUP. ;LOOKUP
JRST OLERRI ;LOOKUP 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. ;
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
TTCALL 3,[ASCIZ /OPEN FAILED - /]
TTCALL 3,[ASCIZ /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,17 ;DUMP MODE
HRRM AC0,UOBLK. ;SETUP OPEN BLOCK
MOVE AC1,F.WDNM(I16) ;
MOVE AC1,(AC1) ;
MOVEM AC1,UOBLK.+1 ;
SETZM UOBLK.+2 ;
PUSHJ PP,SETCN. ;SET DATA FILE CHANNEL
SKIPN F.WSMU(I16) ; SIMULTANEOUS UPDATE?
JRST OPNI21 ; NO
IFE TOPS20,<
PUSHJ PP,OPNFPD ; OPEN FILE VIA FILOP UUO
JRST OFERRI ; ERROR RETURN
>; END IFE TOPS20
IFN TOPS20,<
PUSHJ PP,OCPTD ; OPEN FILE VIA DEC-SYS-20 COMPT.
JRST OCPERI ; ERROR RETURN
>;END IFN TOPS20
JRST OPNI22 ; SKIP THE OPEN UUO
OPNI21: XCT UOPEN. ;OPEN THE DATA FILE
JRST OERRDF ;ERROR RETURN
;SETUP IOWRD TABLE
OPNI22: 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
SKIPN AC4,OMXLVL(I12) ;USE ORIGINAL # OF LEVELS
MOVN AC4,MXLVL(I12) ;MAXIMUM NUMBER OF INDEX LEVELS
MOVEM AC4,OMXLVL(I12) ;SAVE INCASE THIS FILE IS OPENED AGAIN
;[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
JUMPE AC5,OPNI06 ;SKIP THE FOLLOWING IF NOT
HRL AC4,AC5 ;NEW LEVEL(S)
HRRZ AC5,ISPB(I12) ; SECTORS PER BLOCK [EDIT#306]
IMULI AC5,200 ; WORDS PER SECTOR [EDIT#306]
MOVN AC6,AC5 ; NEGATE THE LENGTH [EDIT#306]
HRLZS AC6 ; -LENGTH,,0 [EDIT#306]
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 ;SET UP AC0 [EDIT#306]
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 ; GET PROGRAMS MAX REC SIZE [371]
CAMN AC0,RECBYT(I12) ; SEE IF SAME AS ISAM PARM [371]
JRST OPNI07 ; IT DOES- OF [371]
CAML AC0,RECBYT(I12) ; [375] WHICH WAY IS FD DIFFERENT?
JRST OPNGR ; [375] FD GT ISAM
TLNN FLG,OPNIN+OPNIO ; [375] FD LT ISAM-FILE OPEN FOR OUTPUT?
JRST OPNI07 ; [375] YES OKAY
JRST OPNER1 ; [375] NO-INPUT OR I/O ERROR
OPNGR: TLNN FLG,OPNIO+OPNOUT ; [375] FD GT ISAM- IS FILE OPEN FOR INPUT ?
JRST OPNI07 ; [375] YES OKAY
OPNER1: ; [375]
TTCALL 3,[ASCIZ /USERS MAXIMUM RECORD SIZE /] ; [371]
PUSHJ PP,PUTDEC ; TYPE IT [371]
TTCALL 3,[ASCIZ / DIFFERS FROM ISAM PARAMETER /] ;[371]
MOVE AC0,RECBYT(I12) ; GET ISAM MAX REC SIZE [371]
PUSHJ PP,PUTDEC ; TYPE IT [371]
JRST OPNERX ; FINISH UP MSG AND STOP RUN [371]
OPNI07: ; [371]
PUSHJ PP,OPNWPB ;AC5 = BLKFTR, AC10 = WPB
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
TTCALL 3,[ASCIZ /USERS BLOCKING FACTOR /] ; [371]
MOVE AC0,AC5 ; GET USER BF [371]
PUSHJ PP,PUTDEC ; TYPE IT [371]
TTCALL 3,[ASCIZ / DIFFERS FROM ISAM PARAMETER /] ;[371]
MOVE AC0,AC6 ; GET ISAM BF [371]
PUSHJ PP,PUTDEC ; TYPE IT [371]
OPNERX: ; [371]
TTCALL 3,[ASCIZ/
/] ; [371]
MOVE AC2,[BYTE (5) 10,31,20,2]
PUSHJ PP,MSOUT.
;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) ;
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 #
;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
;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
TTCALL 3,[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
LDB AC6,[POINT 2,FLG,2] ; GET DEVICE DATA MODE
HRRZ AC6,RBPTBL(AC6) ; AND THEN CHARS PER WORD
HRRZM AC6,D.BPW(I16) ;CHARS PER WORD
JUMPL FLG,OPNWP1 ;JUMP IF ASCII
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
IMUL AC10,AC5 ;WORDS PER LOGBLK
POPJ PP, ;
OPNWP4: SKIPGE D.F1(I16) ; IF VARIABLE LEN EBCDIC RECORDS
ADDI AC10,(AC6) ; INCLUDE RDW WITH REC-SIZE
JRST OPNWP6 ;
OPNWP1: ADDI AC10,2 ;FOR CRLF
OPNWP6:
IFN ISAM,<
TLNE FLG,IDXFIL ;INDEX FILE? [372]
JRST OPNWP5 ; YES USE DIFFERENT CALC [372]
>
IMUL AC10,AC5 ; NO. OF CHARS IN LOGIGAL BLOCK [372]
PUSH PP,AC10 ; SAVE CPL
ADDI AC10,-1(AC6) ; ROUND UP [372]
IDIVI AC10,(AC6) ; NO. OF WORDS PER LOGICAL BLOCK [372]
POP PP,AC6 ; RESTORE CHARS-PER-LOGI-BLK
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 ; VAR-LEN EBCDIC FILE?
ADDI AC10,1 ; YES - ADD 1 FOR BDW
POPJ PP, ; [372]
;RECORDING MODE IS BINARY--CONVERT SIZE TO WORDS
OPNWP3: 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: JUMPL FLG,OPNCON ;JUMP IF DEVICE IS ASCII
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
TLNN AC13,20 ; 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, ; ERROR RET - ASSUME ITS OK (IE 9TRK)
TRNE AC1,1B31 ; 9 CHANNEL?
JRST OPNBS1 ; 7 CHANNEL.
MOVEI AC6,^D8 ; 9TRK SO 8 BITS WIDE
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,(JFCL) ; 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,(JFCL) ; NO CONVERSION
MOVEM AC3,D.WCNV(I16) ; SAVE FOR LATER - WRITE
MOVEI AC0,200 ;DSK BUFFER SIZE
TLNE FLG,OPNIO!RANFIL!IDXFIL ;SKIP IF NOT RANDOM OR IO
JRST OPNBP3 ;
TLNN AC13,20 ;SKIP IF A MTA
JRST OPNBP1 ;JUMP, NOT A MTA
JUMPE AC5,OPNBP1 ;JUMP IF BLK-FTR IS ZERO (AC5)
MOVEI AC10,1 ;ONE BUFFER PER LOGICAL BLOCK
JRST OPNBP2 ;
OPNBP1: HRRZ AC11,D.IBH(I16) ;ASSUME INPUT
TLNN FLG,OPNIN ;SKIP IF INPUT
HRRZ AC11,D.OBH(I16) ;MUST BE OUTPUT
HLRZ AC0,(AC11) ;BUFFER SIZE + 1 IN WORDS
SUBI AC0,1 ;SIZE
OPNBP3: IDIV AC10,AC0 ;/BUF-SIZE
SKIPE AC10+1 ;ROUND UP
ADDI AC10,1 ;AC10=BUFFERS PER LOGICAL BLOCK
OPNBP2: MOVEM AC10,D.BPL(I16) ;BUFBLK
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
HRR AC10,F.RRRC(I16);GET RERUN RECORD COUNT
HRRZM AC10,D.RRD(I16) ;NUMBER OF RECORDS TO A RERUN DUMP
OPNBP4: TLNE AC13,20 ;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: TLNN AC16,OPEN ;OPEN UUO SKIPS
JRST OPNLO1 ;
MOVEI AC0,2020 ;SIXBIT REEL NUMBER '00'
LDB AC1,F.BPMT ;FILE POSITION (ON MTA)
SKIPN AC1 ;SKIP IF MULTI-FILE-REEL
ADDI AC0,1 ;MULTI-REEL-FILE REEL '01'
TLNN AC16,1000 ;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
TLNN AC13,4 ;SKIP IF DIRECTORY DEVICE
JRST OPNRLB ;READ LABEL INTO RECORD AREA
SKIPE F.WSMU(I16) ; SIMULTANEOUS UPDATE?
JRST OPNLU1 ; YES
XCT ULKUP. ;*** LOOKUP ***************
JRST OPNLER ;ERROR RETURN
OPNLU1: TLNE FLG,OPNIO ; TRY FOR EXTENDED LOOKUP
PUSHJ PP,OPNELO ; IF VLEN EBCDIC SEQIO FILE
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
MOVE AC0,ULBLK. ;FILE NAME
MOVE AC1,ULBLK.+1 ;EXTENSION
TLNE AC13,100 ;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,(SIXBIT /HDR/) ;LABEL TYPE
IORI AC1,(SIXBIT /1/)
MOVEM AC1,STDLB. ;
LDB AC4,[POINT 12,ULBLK.+2,35] ;GET LOW ORDER CREA DATE
LDB AC1,[POINT 3,ULBLK.+1,20] ;GET HIGH ORDER [EDIT#274]
DPB AC1,[POINT 3,AC4,23] ;MERGE THE ORDERS [EDIT#274]
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
OPNELO: SKIPE F.WSMU(I16) ; IF SMU-ING
POPJ PP, ; WE'VE ALREADY BEEN HERE
OPNEL1: HRRZ AC5,F.RPPN(I16) ; GET POINTER TO PPN
SKIPE AC5 ; USE DEFAULT PPN IF NONE
MOVE AC5,(AC5) ; GET THE PPN
MOVEM AC5,ARGBK.##+.RBPPN ;
MOVE AC5,[ULBLK.,,ARGBK.+.RBNAM]; GET FILE NAME
BLT AC5,ARGBK.+.RBEXT ; AND EXTENSION
HLLZS ARGBK.+.RBEXT ; ZERO DATE FIELD
SETZM ARGBK.+.RBPRV ; AND PRIVILIGE FIELD
SETZM ARGBK.+.RBSIZ ; AND SIZE FIELD
MOVE AC0,ULKUP. ; GET A LOOKUP INST
HRRI AC0,ARGBK. ; SETUP E FIELD
XCT AC0 ; EXTENDED LOOKUP
SKIPA AC5,ARGBK.+.RBEXT ; ERROR SO GET ERROR BITS
JRST OPNEL2 ; NORMAL RETURN
HRRM AC5,ULBLK.+1 ; SAVE BITS FOR OPNLER
JRST OPNLER ; COMPLAIN
OPNEL2: MOVE AC5,ARGBK.+.RBSIZ ; GET LAST BLOCK OF FILE
ADDI AC5,177 ; DIVIDE WORDS WRITTEN BY
IDIVI AC5,200 ; WRDS/BLK AND ROUND UP
MOVE AC6,D.BPL(I16) ; GET NUMBER OF FIRST
ADDI AC5,-1(AC6) ; SECTOR OF THE LAST
IDIV AC5,AC6 ; LOGICAL BLOCK
SKIPN AC5 ; IF FILE DOESN'T EXIST
MOVEI AC5,1 ; ONE IS THE FIRST BLOCK
MOVEM AC5,D.LBN(I16) ; SAVE IT FOR SEQIO
POPJ PP, ;
OPNLER: 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!OPNIO ;RANDOM OR IO OUTPUT FILE?
JRST OLERR ;NO
;HERE TO CREATE A NULL FILE FOR USER
PUSHJ PP,OPNEID ;SETUP FOR AN ENTER
XCT UENTR. ;CREATE A NULL FILE
JRST OEERR ;ERROR RETURN
XCT UCLOS.
JRST OPNLUP ;OK TRY THE LOOKUP AGAIN
IFE TOPS20,<
; 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
TLNN FLG,OPNIO ; IF EXTENDED LOOKUP MUST BE DONE
JRST OPNFP1 ; NO
XCT UOPEN. ; DO IT BEFORE THE FILOP. UUO
JRST OERRIF ; SO WE DONT GET
PUSHJ PP,OPNELO ; ILLEGAL SEQUENCE OF UUO'S ERROR
OPNFP1: LDB AC0,DTCN. ; GET CHANNEL NUMBER
OPNFP2: HRLI AC0,5 ; MULTI ACCESS-UPDATE
MOVSM AC0,FOP.BK ; SAVE IN FILOP BLOCK
MOVE AC0,UOBLK.+1 ; GET DEVICE NAME
MOVEM AC0,FOP.DN ;
MOVEI AC0,ULBLK. ; GET ADR OF LOOKUP BLOCK
MOVEM AC0,FOP.LB ;
MOVE AC1,[7,,FOP.BK] ; SET UP FILOP'S AC
FILOP. AC1, ; OPEN THE FILE SIMULTANEOUS-UPDATE
POPJ PP, ; ERROR RETURN
IFN ISAM,<TLZ FLG1,FOPIDX> ; CLEAR FLAG
JRST RET.2 ; EXIT
; FILOP ERROR
OFERR: SETZM FS.IF ; IDA-FILE FLAG
IFE ISAM,<TLO FLG1,FOPERR> ; FILOP. FAILED
IFN ISAM,<
OFERRI: 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
PUSHJ PP,ERCDF ; IGNORE ERROR?
JRST RCHAN ; YES
JRST LUPERR ; NO
>; END IFE TOPS20
IFN TOPS20,<
SEARCH MONSYM, MACSYM
.REQUIRE SYS:MACREL
EXTERN CP.BLK,CP.BK1,CP.BK2,CP.BK3,CP.BK4,CP.BK5,CP.BK6,CP.BK7,FID.PT
E.MCPT==^D8000000 ; MONITOR COMPT. UUO ERROR
;HERE IF THIS IS A DEC-SYSTEM-20 TO OPEN FILE FOR SIMULTANEOUS UPDATING
;INIT THE CMPT. JSYS ARG BLOCK
OCPT: TLNN FLG,IDXFIL ; ISAM FILE?
JRST OCPTD ; NO
PUSHJ PP,OPNLIX ; YES, GET VID TO LOOKUP BLOCK
TLOA FLG1,FOPIDX ; AN IDX FILE
OCPTD: ;ENTRY POINT FOR ISAM.IDA FILES
PUSHJ PP,OPNLID ; NO, GET VID...
SETZM CP.BK1 ; AC1 GTJFN BITS
;BUILD A SNARK FILE-DESCRIPTOR STRING - AC2 GTJFN BITS
;FIRST JUST MOVE THE DEVICE NAME
MOVE AC5,FID.PT ; GET POINTER TO FILE-DESCRIPTOR
MOVEM AC5,CP.BK2 ; INIT COMPT. ARG BLOCK
MOVE AC0,[POINT 6,UOBLK.+1] ; POINTER TO DEVICE NAME
MOVEI AC1,6 ; GET MAX OF SIX CHARS
OCPT1: ILDB C,AC0 ; GET CHAR
JUMPE C,OCPT2 ; DONE IF NULL
ADDI C,40 ; CONVERT TO ASCII
IDPB C,AC5 ; PUT CHAR IN STRING
SOJG AC1,OCPT1 ; LOOP
OCPT2: MOVEI C,":" ; DEVICE TERMINATOR
IDPB C,AC5 ; TO STRING
;CONVERT PPN TO <DIRECTORY>
MOVEI C,"<" ; ORIGINATE DIRECTORY
IDPB C,AC5 ;
HRRZ AC1,F.RPPN(I16) ; GET ADR OF PPN
JUMPN AC1,OCPT3 ; JUMP IF YOU GOT ONE
GJINF ; GET CONNECT DIR # IN AC2
MOVE AC1,AC5 ; GET THE STRING POINTER
DIRST ; STICK DIR # INTO STRING
POPJ PP, ; IMPOSSIBLE!
MOVEM AC1,AC5 ; GET STRING PTR BACK TO AC5
JRST OCPT4 ;
OCPT3: MOVE AC1,(AC1) ; GET PPN FROM ADR
MOVEM AC1,CP.BK1 ; PPN TO THE ARG-BLOCK
MOVEM AC5,CP.BK2 ; SUPPLY STRING PTR
MOVEI AC0,3 ; FUNCTION 3
MOVEM AC0,CP.BLK ;
MOVE AC0,[3,,CP.BLK] ; SETUP FOR COMPT.
COMPT. AC0, ; MOVE DIR # TO STRING
POPJ PP, ;
MOVE AC5,CP.BK2 ; RESTORE STRING PTR
OCPT4: MOVEI C,">" ; TERMINATE DIRECTORY
IDPB C,AC5 ;
;SETUP THE CP.BK? ARGUMENT BLOCK FOR COMPT. UUO
HRLZI AC0,(1B17) ; SPECIFY THE SHORT FORM OF
MOVEM AC0,CP.BK1 ; OPENF. JSYS
MOVE AC0,FID.PT ; GET POINTER TO FILE DESCRIPTOR STRING
MOVEM AC0,CP.BK2 ; FOR OPENF. ARGUMENT
;MOVE VALUE OF ID TO F-D STRING
TLNE FLG,IDXFIL ; SKIP IF NOT ISAM FILE
TLNE FLG1,FOPIDX ; SKIP IF ISAM .IDA FILE
SKIPA AC4,F.WVID(I16) ; BYTE-PTR TO VALUE OF ID
MOVE AC4,[POINT 6,DFILNM(I12)]; .IDA - SO VALUE-ID IS HERE
MOVEI AC0,11 ; MAX OF 11 CHARS
OCPT5: ILDB C,AC4 ; GET A CHAR
TLNN AC4,600 ; IS VID IN EBCDIC?
LDB C,PTR.96##(C) ; YES - CONVERT IT
TLNN AC4,100 ; HOW BOUT SIXBIT?
ADDI C,40 ; YES
CAIE C," " ; SPACES ARE IGNORED IN FILENAME
IDPB C,AC5 ; STUFF IT AWAY
CAIE AC0,4 ; IS IT TIME FOR A "."?
SOJN AC0,OCPT5 ; NO - LOOP TILL DONE
JUMPE AC0,OCPT6 ; JUMP IF DONE
MOVEI C,"." ; TERMINATE THE FILENAME
IDPB C,AC5 ;
SOJN OCPT5 ; BACK FOR THE EXTENSION
OCPT6: SETZB C,AC0 ; A NULL
IDPB C,AC5 ; TERMINATE THE STRING
;INIT AC2 OPENF BITS
TLNE FLG,DDMASC ; DEVICE DATA MODE ASCII?
TLO AC0,(7B5) ; YES
TLNE FLG,DDMSIX ; SIXBIT?
TLO AC0,(6B5) ; YES
TLNE FLG,DDMBIN ; BINARY?
TLO AC0,(44B5) ; YES
TLNN FLG,DDMEBC ; EBCDIC?
JRST OCPT10 ; NO
TLO AC0,(10B5) ; ASSUME DEVICE IS A MAG-TAPE
TLNN AC13,20 ; DEVICE A MTA?
TLO AC0,(11B5) ; NO, ITSA DSK
OCPT10: TLNE FLG,OPNIO!RANFIL!IDXFIL ; RANDOM, INDEXED OR IO FILES
TLO AC0,(17B9) ; ARE DUMP MODE
TLNE FLG,OPNIO!RANFIL!IDXFIL!OPNIN; OPEN FOR INPUT?
TRO AC0,1B19 ; YES
TLNE FLG,OPNOUT ; OPEN FOR OUTPUT?
TRO AC0,1B20 ; YES
TRO AC0,1B25 ; THAWED I.E. SIMULTANEOUS UPDATE
MOVEM AC0,CP.BK3 ; INIT AC2 OPENF BITS
;INITIALIZE TO TOPS-10 OPEN MODE
TLNE FLG,DDMASC ; DATA-MODE ASCII?
TDZA AC0,AC0 ; YES
MOVEI AC0,14 ; NOT ASCII
TLNE FLG,RANFIL!IDXFIL!OPNIO ; THESE FILES ARE NOT BUFFERED
MOVEI AC0,17 ; DUMP MODE
MOVEM AC0,CP.BK4 ; OPEN MODE
;LOCATE THE BUFFER HEADERS AND EXTENDED LOOKUP BLOCK
MOVEI AC0,D.IBH(I16) ;
MOVEM AC0,CP.BK5 ; INPUT BUFFER HEADER
MOVEI AC0,D.OBH(I16) ;
MOVEM AC0,CP.BK6 ; OUTPUT BUFFER HEADER
MOVEI AC0,ARGBK. ;
MOVEM AC0,CP.BK7 ; ADR OF EXTENDED LOOKUP BLOCK
;SET UP EXTENDED LOOKUP BLOCK
HRRZ AC1,F.RPPN(I16) ; GET ADR OF PPN
SKIPE AC1 ; USE DEFAULT PPN IF ZERO
MOVE AC1,(AC1) ; GET PPN
MOVEM AC1,ARGBK.##+.RBPPN ; SETUP PPN
MOVE AC1,[ULBLK.,,ARGBK.+.RBNAM]; COPY FILE-NAME.EXT
BLT AC1,ARGBK.+.RBEXT ; FROM LOOKUP BLOCK
HLLZS ARGBK.+.RBEXT ; CLEAR RIGHT HALF
SETZM ARGBK.+.RBPRV ; AND PRIV
SETZM ARGBK.+.RBSIZ ; AND SIZE
TLNE FLG1,FOPIDX ; IF AN ISAM.IDX FILE GET CHAN #
SKIPA AC1,ICHAN(I12) ; FROM HERE
LDB AC1,DTCN. ; ELSE FROM HERE
HRLI AC1,1 ; THE FUNCTION
MOVSM AC1,CP.BLK ; ARG ,, FUNCTION
MOVE AC1,[10,,CP.BLK] ; COUNT,,ADR FOR ARG-BLOCK
COMPT. AC1, ; OPEN FILE FOR SIMULTANEOUS UPDATE
POPJ PP, ; ERROR RETURN
IFN ISAM,<TLZ FLG1,FOPIDX> ; CLEAR FLAG
JRST RET.2 ; 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] ;
PUSHJ PP,IGCVR ; IGNORE ERROR?
JRST RCHAN ; YES
OCPERR: TTCALL 3,[ASCIZ /COMPT. UUO FAILED /]
MOVEI AC0,.PRIIN ;
CFIBF ; CLEAR TYPE AHEAD
MOVEI AC0,.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. ; FATAL ERROR MESSAGE
>;END OF IFN TOPS20
;READ A LABEL FROM A NON DIRECTORY DEVICE. ***OPNBBF***
OPNRLB: TLNN AC13,140610 ;SKIP IF DEVICE IS - CDR,LPT,TTY,PTR,OR PTP [RPGLIB EDIT #64]
TLNN FLG1,NONSTD+STNDRD ;SKIP IF LABELS ARE PRESENT
JRST OPNBBF ;
OPNRL2: 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,OPNIO!RANFIL!IDXFIL ;SKIP IF NOT DUMP MODE
JRST OPNBB1 ;
TLNN FLG,OPNOUT ; SKIP IF OUTPUT [EDIT#301]
JRST OPNBB1 ;;NOT OUTPUT,SKIP ENTER [EDIT#301]
TLNE AC13,4 ;DIRECTORY DEVICE? [EDIT#315]
JRST OPNBB2 ;YES, SKIP ENTER [EDIT#315]
PUSHJ PP,OPNEID ;SET UP ID FOR ENTER [EDIT#301]
XCT UENTR. ;DO AN ENTER [EDIT#301]
JRST OEERR ;ERROR RETURN [EDIT#301]
OPNBB2: XCT UOUT. ;DUMMY OUTPUT********************[EDIT#315]
OPNBB1: MOVEI AC1,1 ;2 WORD CALL,
PUSHJ PP,USEPRO ;TO GET THE USE PRO. ADDRESS
TLNN AC13,140610 ;NO LABELS - NO CHECKS [RPGLIB EDIT #64]
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: MOVEI AC1,2 ;TWO WORD CALL
PUSHJ PP,USEPRO ;TO GET USE PRO. ADR.
TLNN FLG,OPNOUT ;OUTPUT SKIPS
JRST OPNDVC
TLNE AC13,4 ;SKIP IF NOT DIR. DEV.
JRST OPNENR
TLNN AC13,140614 ;SKIP IF CDR,LPT,TTY,PTR,PTP,OR DTA,DSK. [RPGLIB EDIT #64]
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
IFN EBCLBL ,<
TLNN FLG,DDMEBC ;EBCDIC?
JRST OPNDVC ;NO
XCT UCLOS. ;WRITE A TAPE MARK AFTER THE LABELS
PUSHJ PP,WRTWAI ;WAIT FOR ERROR CHECKING
XCT UOUT. ;DUMMY OUTPUT
>
JRST OPNDVC
;DO AN ENTER AND SAVE THE FLAG REGISTER. ***EXIT TO THE ACP***
OPNENR: PUSHJ PP,OPNEID ;SETUP UEBLK. (DUMP-MODE)
SKIPE F.WSMU(I16) ; SIMULTANEOUS UPDATE?
JRST OPNEN1 ; YES - SKIP THE ENTER
XCT UENTR. ;ENTER - DIRECTORY DEVICE**********
JRST OEERR ;ERROR RETURN
OPNEN1: TLNN FLG,RANFIL!OPNIO!IDXFIL ;DUMP MODE HAS NO DUMMY OUTPUTS
XCT UOUT. ;DUMMY OUTPUT*****ENTER VOIDS PREVIOUS DUMMY OUTPUTS.
OPNDVC: MOVE AC13,UOBLK.+1
CALLI AC13,4 ;THE FINAL DEVCHR
TLNN FLG,OPNIO+OPNIN ;[330]IF NOT INPUT THEN IGNORE
JRST OPNDV1 ;[330]
TLC AC13,300000 ;[330]IF A DSK AND A CDR
TLCN AC13,300000 ;[330]THEN ITS DEVICE 'NUL'
TLZ AC13,20 ;[330]SO ITS NOT A MAGTAPE
OPNDV1: MOVEM AC13,D.DC(I16) ;[330]
MOVEM FLG,F.WFLG(I16) ;UPDATE THE FLAGS
TLNE AC13,10 ;IS THIS A TTY FILE?
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
TLNN AC16,SLURP ;RESTORE THE REC-AREA IF A WRITE REEL CHANGE
POPJ PP, ;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
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
LDB C,PTR.79## ; EBCDIC
MOVS C,CHTAB(C) ; SIXBIT
RCEBC: LDB C,PTR.97## ; EBCDIC TO ASCII
JFCL ; EBCDIC
LDB C,PTR.96## ; SIXBIT
RCSIX: ADDI C,40 ; SIXBIT TO ASCII
LDB C,PTR.69## ; EBCDIC
JFCL ; SIXBIT
WCTBL: WCASC(AC1) ; ASCII TO ?
RCEBC(AC1) ; EBCDIC TO ?
RCSIX(AC1) ; SIXBIT TO ?
WCASC: JFCL ; ASCII TO ASCII
LDB C,PTR.79## ; EBCDIC
MOVS C,CHTAB(C) ; SIXBIT
;STANDARD LABELS AND INPUT OR IO
;CHECK THE VALUE OF ID. ***OPNABF***
OPNCSL: 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 ;
IFN EBCLBL ,<
TLNE FLG,DDMEBC ;IF EBCDIC
PUSHJ PP,OECLT ; LOOK FOR 'VOL1' IF FIRST FILE
>
CAMN AC0,[SIXBIT /HDR1/] ;SKIP INTO ERROR MESSAGE
JRST OPNCID ;CHECK VALUE OF ID
;MISSING OR WRONG LABEL TYPE
TTCALL 3,[ASCIZ/$ THE BEGINNING FILE LABEL IS MISSING/]
OPNCL1: PUSHJ PP,SAVAC.
MOVE AC2,[BYTE(5)10,2,31,20,4,14]
PUSHJ PP,MSOUT.
JRST OPNFW4 ;TRY AGAIN
IFN EBCLBL ,<
OECLT: LDB AC2,F.BPMT ;GET FILE POSITION
SOJG AC2,RET.1 ; AND RETURN IF NOT FIRST FILE ON REEL
CAME AC0,[SIXBIT /VOL1/] ;LABEL TYPE MUST BE 'VOL1'
JRST OECL1 ; ELSE ERROR MESSAGE
PUSHJ PP,READSY ;READ NEXT LABEL, SHLDB 'HDR1'
JRST .+2 ;OK
JRST OECL2 ;ERROR RETURN, MESSAGE & SECOND CHANCE
PUSHJ PP,BUFREC ;MOVE LABEL INTO RECORD AREA
PUSHJ PP,RECSLB ; THEN TO LABEL AREA
MOVE AC0,STDLB. ;LABEL TYPE TO AC0
TRZ AC0,7777 ; AND CLEAR THE GARBAGE
POPJ PP, ;TRY FOR 'HDR1'
OECL1: TTCALL 3,[ASCIZ /LABEL "VOL1" IS MISSING/]
POP PP,(PP) ; KEEP THE STACK RIGHT
JRST OPNCL1
OECL2: POP PP,(PP) ; MAKE THE STACK RIGHT
JRST OPNRL2 ; ERROR PATH
>
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. ;
TTCALL 3,[ASCIZ/$ THE VALUE OF ID DOES NOT MATCH THE LABEL ID/]
JRST OPNFW4
;CHECK DATE WRITTEN
OPNCDW: SKIPN AC5,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 AC6,AC5 ;ONE FROM THE FILE TABLE
TLNE AC5,100 ;SKIP IF SIXBIT
SUBI AC6,40 ;MAKE IT SIXBIT
TLNN AC5,600 ; EBCDIC?
LDB AC6,PTR.96##(AC6) ; YES
CAME AC6,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.
TTCALL 3,[ASCIZ /THE FILE TABLE DATE DIFFERS FROM THE FILE LABEL DATE/]
JRST KILL
;CHECK THE REEL NUMBER IF THE DEVICE IS A MAGTAPE
OPNCRN: TLNN AC13,20 ;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. ;
TTCALL 3,[ASCIZ /
$/]
MOVE AC2,[BYTE(5)10,31,20,2,4,34,14] ;FODC.R#
PUSHJ PP,MSOUT. ;
TTCALL 3,[ASCIZ/ WAS MOUNTED, PLEASE MOUNT /]
PUSHJ PP,MSDTRN
TTCALL 3,[ASCIZ /
THEN/]
JRST OPNF04 ;TRY AGAIN
OPNCR1:
IFN EBCLBL ,<
TLNE FLG,DDMEBC ;IF EBCDIC
XCT MADVF. ; SKIP TO TAPE MARK
>
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
IFN EBCLBL,<
LDB AC0,F.BPMT ;GET FILE POSITION
TLNE FLG,DDMEBC ;EBCDIC?
SOJLE AC0,[ ;MAKE A 'VOL1' LABEL
MOVE AC0,[SIXBIT /VOL1/]
MOVEM AC0,STDLB. ;'VOL1' TO THE LABEL AREA
PUSHJ PP,SLBREC ;MOVE TO RECORD AREA
PUSHJ PP,RECBUF ; THEN TO THE BUFFER
PUSHJ PP,WRTOUT ; AND WRITE IT
SETZM STDLB. ;ZERO THE LABEL AREA
JRST .+1] ;RETURN
>
MOVE AC0,UEBLK. ;FILENAME
HLLZ AC1,UEBLK.+1 ;EXT
ROTC AC0,14 ;12 PLACES TO THE LEFT - MARCH.
TRO AC1,(SIXBIT /1/);FIRST LABEL
MOVEM AC0,STDLB.+1 ;FILE
HLLM AC1,STDLB.+2 ;DESCRIPTOR
TLNE AC16,OPEN+CLOSEB
HRLI AC1,(SIXBIT /HDR/) ;BEGINNING FILE LABEL
TLNE AC16,CLOSEF
HRLI AC1,(SIXBIT /EOF/) ;END OF FILE LABEL
TLNE AC16,CLOSER
HRLI AC1,(SIXBIT /EOV/) ;END OF VOLUME LABEL
MOVEM AC1,STDLB. ;
IFN EBCLBL,<
TLNE FLG,DDMEBC ;EBCDIC?
PUSHJ PP,JULIA0 ;JULIAN DATE & SKIP EXIT (YYDDD)
>
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
IDIVI AC0,^D10 ;
ADDM AC1,AC2 ;
ROT AC2,6 ;
JUMPN AC0,.-3 ;CONVERTED TO DECIMAL
ADD AC2,[20202020] ;SIXBITIZED
LDB AC1,DTRN. ;DEVTAB MAG-TAPE REEL NUMBER
ROT AC2,14 ;
ROTC AC1,-6 ;
ADDI AC1,202000 ;
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,.JBVER
ROTC AC0,14
ROT AC1,3
ROTC AC0,3
ROT AC1,3
ROTC AC0,3
ADDI AC1,202020
HRLZM AC1,STDLB.+13 ;PDP10 VER
JRST SLBREC ;MOVE STD-LABEL TO RECORD AREA AND EXIT
;SET MAGTAPE DENSITY & PARITY
;POSITION MAGTAPE VIA FILE TABLE FILE POSITION. ***OPNLO***
OPNMTA: TLNN FLG,DDMEBC ; RECORDING MODE EBCDIC?
JRST OMTA10 ; NO
TLNE FLG1,NONSTD!STNDRD; LABELS OMITTED?
JRST OMTA98 ; NO - ERROR
HRRZ AC1,F.WDNM(I16) ; GET THE SIXBIT
MOVE AC1,(AC1) ; DEVICE NAME AND
MTCHR. AC1, ; GET CHARACTERISTICS
SETZ AC1, ; ERROR RET - ASSUME 9TRK
TRNE AC1,1B31 ; 9 TRACKS?
JRST OMTA10 ; NO - 7 TRK
HRLZI AC3,3 ; LENGTH ,, ADDR
MOVEI AC0,.TFMOD ; FUNCTION
MOVE AC1,UOBLK.+1 ; DEVICE NAME
MOVEI AC2,.TFM8B ; INDUSTRY-COMPATIBLE MODE
TAPOP. AC3, ; DOIT
JRST OMTA93 ; ERROR - COMPLAIN
;SET PARITY
OMTA10: 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
;STANDARD-ASCII OR 1600 BPI WANTED?
OMTA20: LDB AC5,F.BDNS ; GET DENSITY
HRRZ AC6,D.RFLG(I16) ; GET STANDARD ASCII FLAG
CAIGE AC5,4 ; SKIP IF 1600 BPI
TRNE AC6,SASCII ; DOES HE WANT IT?
JRST OMTA21 ; YES
;SET DENSITY
XCT UGETS. ;GET STATUS
DPB AC5,[POINT 3,AC2,28]
XCT USETS. ;SET STATUS
JRST OPNPMT ;
;TU16/43/45/70 REQUIRED - DO WE HAVE ONE?
OMTA21: HRLZI AC3,2 ; LENGTH ,, ADDR
MOVEI AC0,.TFKTP ; FUNCTION
MOVE AC1,UOBLK.+1 ; DEVICE NAME
TAPOP. AC3, ; GET CONTROLER TYPE
JRST OMTA90 ; ERROR
TRNN AC6,SASCII ; STD-ASCII REQUEST?
JRST OMTA22 ; NO
CAIE AC3,.TX01 ; TU70 CONTROLLER?
CAIN AC3,.TM02 ; OR A TU16 OR TU45?
JRST .+2 ; YES
JRST OMTA91 ; ERROR - WRONG TYPE
;SET STANDARD ASCII MODE
HRLZI AC3,3 ; LENGTH ,, ADDR
MOVEI AC0,.TFMOD ; FUNCTION
MOVEI AC2,.TFM7B ; STANDARD ASCII MODE
TAPOP. AC3, ; CHANGE MODE
JRST OMTA93 ; ERROR - COMPLAIN
;TU16/43/45/70 CAN ONLY DO 800 OR 1600 BPI
JUMPE AC5,OPNPMT ; USE DEFAULT DENSITY
CAIE AC5,3 ; 800 BPI?
CAIN AC5,4 ; 1600?
JRST OMTA30 ; YES SO SET IT
JRST OMTA94 ; NO COMPLAIN
OMTA22: CAIE AC3,.TC10C ; TU43 CONTROLLER?
CAIN AC3,.TX01 ; TU70?
JRST OMTA30 ; OK
CAIE AC3,.TM02 ; TU16/45?
JRST OMTA92 ; NO COMPLAIN
;SET DENSITY
OMTA30: HRLZI AC3,3 ; LENGTH,,ADR
MOVEI AC0,.TFSDN ; SET DENSITY FUNCTION
MOVE AC1,UOBLK.+1 ; DEVICE NAME
MOVE AC2,AC5 ; REQUESTED DENSITY
TAPOP. AC3, ; SET IT
JRST OMTA95 ; OOPS
;NOW GET/CHECK DENSITY
HRLZI AC3,2 ; LEN,,ADR
MOVEI AC0,.TFGDN ; GET DENSITY FUNCTION
MOVE AC1,UOBLK.+1 ; DEVICE NAME
TAPOP. AC3, ; GET DENSITY
JRST OMTA95 ; OOPS
CAME AC2,AC3 ; CHECK IT
JRST OMTA95 ; ERROR - NOT WHAT 'E ASKED FOR
JRST OPNPMT ;
;HERE IF TAPOP. ERROR RET OR NOT A TU16/45/70 DRIVE
OMTA90: TRNN AC6,SASCII ; STD-ASCII MESSAGE?
JRST OMTA92 ; NO 1600 BPI
OMTA91: MOVE AC0,[E.FIDX+^D37]; ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE ERROR?
JRST RCHAN ; YES
TTCALL 3,[ASCIZ / STANDARD ASCII RECORDING MODE REQUIRES A TU16, TU45 OR TU70/]
JRST OMTA99 ;
;1600 BPI WANTS A TU16/43/45/70
OMTA92: MOVE AC0,[E.FIDX+^D38]; ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE ERROR?
JRST RCHAN ; YES
TTCALL 3,[ASCIZ / DENSITY OF 1600 BPI REQUIRES A TU16, TU43, TU45 OR TU70/]
JRST OMTA99 ;
;TAPOP. FAILED TO SET STANDARD ASCII MODE
OMTA93: MOVE AC0,[E.FIDX+^D45]; ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE THE ERROR?
JRST RCHAN ; YES
TTCALL 3,[ASCIZ / TAPOP. FAILED - UNABLE TO SET STANDARD-ASCII OR INDUSTRY-COMPATIBLE MODE/]
JRST OMTA99
;TU16/43/45/70 CAN DO ONLY 800/1600 BPI
OMTA94: MOVE AC0,[E.FIDX+^D46]; ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE THE ERROR?
JRST RCHAN ; YES
TTCALL 3,[ASCIZ " TU16/43/45/70 CAN HAVE DENSITY OF ONLY 800 OR 1600 BPI"]
JRST OMTA99
;TAPOP. FAILED OR "SET" DOESN'T MATCH "GET" DENSITY
OMTA95: MOVE AC0,[E.FIDX+^D47]; ERROR NUMBER
PUSHJ PP,IGCVR ; IGNORE THE ERROR?
JRST RCHAN ; YES
TTCALL 3,[ASCIZ / CANNOT SET THE REQUESTED DENSITY/]
JRST OMTA99
;FOR NOW EBCDIC FILES MUST HAVE OMITTED LABELS
OMTA98: TTCALL 3,[ASCIZ / EBCDIC MTA FILES MUST HAVE OMITTED LABELS /]
OMTA99: MOVE AC2,[BYTE (5) 10,31,20,2]
PUSHJ PP,MSOUT. ;DOESN'T RETURN
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.
HRLZI AC5,HUF ;"HEAD UNDER THIS FILE" FLAG
LDB AC11,F.BPMT ;POINT 6,6(I16),17 ... FILE POSITION ON REEL
JUMPE AC11,OPNF00 ;JUMP IF MULTI REEL FILE WAS OPNREW
MOVE AC10,AC16 ;CURRENT FILE TABLE FIRST
OPNHUF: TDNE AC5,D.HF(AC10) ;SKIP IF NOT "HUF"
JRST OPNFND ;FOUND THE FILE
HRRZ AC10,11(AC10) ;NEXT FILE TABLE THAT SHARES THIS REEL
CAIE AC10,(I16) ;SKIP IF WE'VE MADE A COMPLETE LOOP
JUMPN AC10,OPNHUF ;ZERO=REEL NOT SHARED
;FALL THRU IF REEL NEVER POSITIONED
OPNREW: 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,
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: 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
JRST OPNLO ;EXIT FROM OPNPMT
OPNF00: TLNE AC16,100 ;REWIND REQ ?
JRST OPNFW1 ;NO
JRST OPNREW ;YES
OPNRE1: TTCALL 3,[ASCIZ /$ UNEXPECTED BOT MARKER/] ; [EDIT#277]
SKIPA
OPNFW2: TTCALL 3,[ASCIZ /$ UNEXPECTED EOT MARKER/] ; [EDIT#277]
PUSHJ PP,SAVAC.
TTCALL 3,[ASCIZ /$ ENCOUNTERED WHILE POSITIONING /]
MOVE AC2,[BYTE (5)10,31,20,14] ;FILE ON DEVICE.
PUSHJ PP,MSOUT.
OPNFW4: TLNN AC13,120 ;SKIP IF A REEL DEVICE
JRST KILL ;
TTCALL 3,[ASCIZ /
WRONG REEL? /]
OPNF04: PUSHJ PP,C.STOP ;TYPE CONTINUE TO RETRY
PUSHJ PP,RSTAC.
HRLZI AC5,HUF ;ANOTHER TAPE WAS MOUNTED
ANDCAM AC5,D.HF(I16) ;CLEAR THE "HEAD-UNDER-FILE" FLAG
JRST OPNBP4 ;TRY AGAIN
;PLACE VALUE OF ID IN LOOKUP/ENTER BLOCK
OPNLID: SKIPA AC10,[POINT 6,ULBLK.] ;LOOKUP SETUP
OPNEID: MOVE AC10,[POINT 6,UEBLK.] ;ENTER SETUP
IFN ISAM,<
TLNE FLG,IDXFIL ;ISAM ?
SKIPA AC5,[POINT 6,DFILNM(I12)]
>
MOVE AC5,F.WVID(I16) ;BYTE POINTER TO VALUE OF ID
MOVEI AC6,11 ;ID HAS 11 CHARACTERS MAX
OPNEI1: ILDB C,AC5 ;PICK UP A CHAR
TLNN AC5,600 ; IS VID EBCDIC?
LDB C,PTR.96##(C) ; YES - CONVERT TO SIXBIT
TLNE AC5,1100 ;SKIP IF SIXBIT
SUBI C,40 ;CONVERT FROM ASCII
IDPB C,AC10 ;STORE IN E BLOCK
SOJN AC6,OPNEI1 ;LOOP 11
SETZM ULBLK.+3 ;P,,P
SETZM UEBLK.+3 ;PROJ,,PROG
HLLZS ULBLK.+1 ;ZERO RIGHT HALF OF EXTENSION WORD
HLLZS UEBLK.+1 ; IN LOOKUP AND ENTER BLOCK
SETZM UEBLK.+2 ;CLEAR PROTECTION AND DATE
OPNPPN: LDB AC5,F.BCVR ;GET COMPILER NUMBER
CAIGE AC5,3 ;VERSION 3 OR OLDER?
POPJ PP, ;NOP
HRRZ AC5,F.RPPN(I16) ;ADR OF PROJ,,PROG
JUMPE AC5,RET.1 ;USE DEFAULT
MOVE AC5,(AC5) ;PROJECT,,PROGRAMER
MOVEM AC5,ULBLK.+3
MOVEM AC5,UEBLK.+3
POPJ PP, ;AND RETURN
IFN ISAM,<
OPNLIX: MOVEI AC10,OPNLID
SKIPA
OPNEIX: MOVEI AC10,OPNEID
TLC FLG,IDXFIL
PUSHJ PP,(AC10)
TLC FLG,IDXFIL
POPJ PP,
>
;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
TLNE AC16,CLOSEB+CLOSER ;SKIP IF NOT A REEL PRO
JRST USEPR1 ;
LDB AC0,F.BPMT ;FILE POSITION ON MTA
JUMPN AC0,USEPR2 ;JUMP IF MULTI FILE REEL
TLNE AC16,CLOSEF ;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
TLNN AC16,CLOSEB+CLOSER ;EXIT IF A REEL PRO
SKIPN -1(PP) ;OR AN ERROR PRO
JRST RSTAC1 ;EXIT
PUSHJ PP,USESUP ;SETUP
TLNN AC16,CLOSEF ;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
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
TLNE FLG,OPNIN ;SKIP IF NOT INPUT
ADDI AC1,5 ;INPUT/OUTPUT USE PRO
ADDI AC1,5 ;OUTPUT USE PRO
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
TRNN AC1,-1 ;SKIP IF THERE IS A GENERAL USEPRO
HRRZ AC1,AC2 ;GET SPECIFIC FILTAB USEPRO
JUMPN AC1,USEXC1 ;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.
SKIPA
;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
SKIPA ;[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.
TTCALL 3,[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: 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
SUBTTL WRITE OUT THE BUFFER
;ALL BUFFERED OUTPUTS ARE DONE HERE. ***POPJ***
WRTOUT: AOS D.OE(I16) ;BUMP OUTPUT COUNT
XCT UOUT. ;DO THE OUTPUT
POPJ PP, ;NORMAL RETURN
WRTWAI:;**SAVE ACS** PUSHJ PP,SETCN. ; SETUP THE CHANNEL FIELD
XCT UWAIT. ;FOR ALL THE ERRORS
XCT UGETS. ;
TRNE AC2,740000 ;ERRORS?
JRST WRTERR ;THERE ARE ERRORS.
WRTFIN: MOVE AC13,D.DC(I16) ; GET DEVICE CHARACTERISTICS
TLNE AC13,20 ;MTA?
TRNN AC2,2000 ;EOT?
JRST WRTXIT ;NOT A MAGTAPE EOT
TLNE AC16,READ+CLOSEF+CLOSER ;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
TLO AC16,MTAEOT ;EOT FLAG
JRST WRTXIT ;
WRTMFR: MOVE AC0,[E.MOUT] ;OUTPUT ERROR
PUSHJ PP,IGMDR ;IGNORE ERROR?
JRST WRTXIT ;YES
TTCALL 3,[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"
WRTRS1: AOS (PP) ;SKIP EXIT VIA WRITE EXIT
WRTXIT: XCT UGETS. ;GET STATUS
TLNE AC13,20 ;MAGTAPE?
TRZA AC2,762000 ;MAGTAPE.
TRZ AC2,760000 ;OTHER.
XCT USETS. ;SET STATUS
POPJ PP, ;RETURN
WRTERR: TLNE AC13,20 ;MTA?
TRNN AC2,400000 ;WRITE-LOCKED?
JRST WRTER1 ;NO
PUSHJ PP,SAVAC. ;IT'S A WRITE-LOCKED MAGTAPE
TTCALL 3,[ASCIZ /$ /]
MOVE AC2,[BYTE(5)22,27,10,31,20,4,14]
PUSHJ PP,MSOUT. ;"CANNOT DO OUTPUT TO <DEVICE><FILE>
TTCALL 3,[ASCIZ/IS THE DEVICE WRITE ENABLED?/]
PUSHJ PP,C.STOP ;"TYPE CONTINUE TO PROCEDE"
PUSHJ PP,RSTAC. ;RESTORE THE ACS
TRZ AC2,760000 ;TURN OFF THE ERROR BITS
XCT USETS. ;SET STATUS
JRST WRTOUT ;TRY 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: PUSHJ PP,ERCODE ;OUTPUT ERROR STATUS
TRNE AC2,400000
TTCALL 3,[ASCIZ/ IMPROPER MODE/]
TRNE AC2,200000
TTCALL 3,[ASCIZ/ DEVICE ERROR/]
TRNE AC2,100000
TTCALL 3,[ASCIZ/ DATA ERROR/]
TRNN AC2,40000
POPJ PP,
TLNE AC13,200000 ;DSK?
TTCALL 3,[ASCIZ / QUOTA EXCEEDED, FILE STRUCTURE OR RIB FULL/]
TLNE AC13,100 ;DTA?
TTCALL 3,[ASCIZ / BLOCK NUMBER TOO LARGE OR DEC-TAPE IS FULL/]
TLNN AC13,200100 ;ONLY ONE MESSAGE
TTCALL 3,[ASCIZ/ BLOCK TOO LARGE/]
POPJ PP,
;OUTPUT CONTENTS OF AC2 BITS 18-35 (ERROR STATUS)
ERCODE: MOVEI C,"(" ;
TTCALL 1,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
TTCALL 1,C ;OUTPUT IT
SOJG AC1,ERCOD1 ;LOOP
MOVEI C,")" ;
TTCALL 1,C ;OUTPUT )
POPJ PP,
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: ;**BOMB** PUSHJ PP,SETCN. ; SETUP THE CHANNEL FIELD
XCT UGETS. ; GET THE STATUS
MOVE AC13,D.DC(I16) ; AND DEVICE CHARACTERISTICS
TLNN AC13,20 ; MTA ?
JRST READC1 ; NO
TRNE AC2,2000 ;SKIP IF NOT AN "EOT"
TLO AC16,MTAEOT ;"EOT" FLAG FOR READEF+N
READC1: TRNN AC2,760000 ;SKIP IF ANY ERRORS IN THE CURRENT BUFFER
JRST WRTXIT ;CLEAR THE ERRORS AND POPJ
TRNN AC2,20000 ;SKIP IF AN EOF
JRST REAERR ;REAL ERRORS!
TLNN AC16,OPEN+CLOSEB+CLOSER+CLOSEF ;SKIP IF OPEN OR CLOSE
JRST WRTRSX ;JUMP, IT'S READ OR WRITE "EOF"
JRST WRTRS1 ;EXIT BUT DONT SET ATEND
REAERR: 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: 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
SUBTTL TODAY. 8JAN
;CALLED BY PUSHJ PP,TODAY.
;EXIT WITH DATE IN AC0 YYMMDD
; TIME IN AC1 HHMMSS
AC0=0 ;YYMMDD
AC1=1 ;HHMMSS
AC4=4 ;TEMP
AC5=AC4+1 ;TEMP
AC6=AC5+1 ;TEMP
PP=17 ;
INTERN TODAY.,TODA1.,TODA2.
ENTRY MCSTIM ;CMCS (LCM) USES THIS ROUTINE
TODAY.: CALLI AC4,14 ;DATE UUO ((Y-64)*12+(M-1))*31+D-1
TODA1.: IDIVI AC4,^D31 ;PICK OFF THE DAY
ADDI AC5,1 ;MAKE IT RIGHT
PUSHJ PP,TODA4. ;RETURNS TWO SIXBIT NUMBERS
DPB AC5,DAY ;XXXXDD
IDIVI AC4,^D12 ;PICK OFF THE MONTH
ADDI AC5,1 ;MAKE IT RIGHT
PUSHJ PP,TODA4. ;RETURNS TWO SIXBIT NUMBERS
DPB AC5,MONTH ;XXMMDD
MOVEI AC5,^D64 ;GET THE BASE YEAR
ADD AC5,AC4 ;PLUS YEARS SINCE THEN
CAIL AC5,^D100 ;CK FOR YEAR 2000+ [EDIT#274]
SUBI AC5,^D100 ;IF SO, CONVERT TO 00+ [EDIT#274]
PUSHJ PP,TODA4. ;SIXBIT
DPB AC5,YEAR ;YYMMDD-DATE FINISHED
CALLI AC4,23 ;TIME UUO GETS TIME IN MILLISECONDS
IDIVI AC4,^D1000 ;CONVERT TO SECONDS
MCSTIM: PUSHJ PP,TODA3. ;PICK OFF SECONDS IN SIXBIT
DPB AC5,SECOND ;XXXXSS
TODA2.: PUSHJ PP,TODA3. ;PICK OFF MINUTES IN SIXBIT
DPB AC5,MINUTE ;XXMMSS
MOVE AC5,AC4 ;WHAT'S LEFT IS HOURS
PUSHJ PP,TODA4. ;TO SIXBIT
DPB AC5,HOUR ;HHMMSS-TIME FINISHED
POPJ PP, ;RETURN
TODA3.: IDIVI AC4,^D60 ;DIVIDE BY 60 FOR TIME
TODA4.: IDIVI AC5,^D10 ;DIVIDE OUT A DECIMAL NUMBER
LSH AC5,6 ;MAKE ROOM FOR THE REMIANDER
ADDI AC5,2020(AC6) ;CONVERT TO SIXBIT
POPJ PP, ;RETURN
YEAR: POINT 12,AC0,11
MONTH: POINT 12,AC0,23
DAY: POINT 12,AC0,35
HOUR: POINT 12,AC1,11
MINUTE: POINT 12,AC1,23
SECOND: POINT 12,AC1,35
IFN EBCLBL,<
;PUSHJ PP,JULIAN
;RETURNS WITH DATE IN AC0
;AS SIXBIT YYDDD
JULIA0: AOS (PP) ;TAKE A SKIP EXIT
JULIAN: SETZ AC0, ;
CALLI AC4,14 ;GET DATE
IDIVI AC4,^D31 ;PICK OFF DAY-1
ADDI AC5,1 ;DAY OF THE MONTH
MOVE AC1,AC5 ;SAVE THE DAY
IDIVI AC4,^D12 ;PICK OFF MONTH - 1
ADDI AC4,^D64 ;GET YEAR IN AC4
EXCH AC4,AC5 ;SWAP WITH MONTH INDEX
PUSHJ PP,TODA4. ;STORE THE SIXBIT YEAR
DPB AC5,YEAR ; IN AC0
ADD AC1,DAYTAB(AC4) ;ADD PREVIOUS DAYS TO DAY OF MONTH
CAIG AC4,2 ;PAST FEBRUARY?
JRST JULIA1 ;YES
IDIVI AC4,4 ;CHECK FOR LEAP YEAR
CAIG AC5,0 ;LEAP YEAR?
ADDI AC1,1 ;YES
JULIA1: MOVE AC4,AC1 ;
IDIVI AC4,^D10 ;DIVIDE OUT THE
MOVE AC1,AC5 ; UINTS AND
IDIVI AC4,^D10 ; THE TENS
LSH AC4,6 ;SHIFT OVER THE HUNDREDS
ADD AC5,AC4 ;ADD IN THE TENS
LSH AC5,6 ;MAKE ROOM FOR THE UNITS
ADDI AC5,202020(AC1) ;ADDEM IN AND SIXBITIZE
LSH AC5,6 ;GET THEM NEXT TO THE YEAR POSITION
ADD AC0,AC5 ; YYDDD
POPJ PP,
DAYTAB: EXP ^D0 ;JAN
EXP ^D31 ;FEB
EXP ^D59 ;MAR
EXP ^D90 ;APR
EXP ^D120 ;MAY
EXP ^D151 ;JUN
EXP ^D181 ;JUL
EXP ^D212 ;AUG
EXP ^D243 ;SEP
EXP ^D273 ;OCT
EXP ^D304 ;NOV
EXP ^D334 ;DEC
>
SUBTTL ERROR MESSAGES 5-JAN-70
;MOVE AC2,[BYTE (5),1,2,3,4] ;CALLING
;JRST MSOUT. ;SEQUENCE
MSOUT.: PUSHJ PP,DSPL1. ;OUTPUT BUFFER AND "CRLF"
MOVE AC0,[POINT 5,AC2] ;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 .JBAPR ;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
TLNE AC4,20 ; [407] IF SPOOLED FORGET IT
JRST MSDEVA
TTCALL 3,[ASCIZ/ LOGICAL DEVICE /] ; [407]
MOVE AC3,(AC1) ; [407] LOGICAL DEVICE
PUSHJ PP,MSDEV1 ; [407] TYPE IT
TTCALL 3,[ASCIZ/; PHYSICAL DEVICE /] ; [407]
MOVE AC3,AC6 ; [407] PHYSICAL DEVICE
JRST MSDEV1 ; [407] TYPE AND RETURN
MSDEVA:
TTCALL 3,[ASCIZ/ DEVICE /]
MOVE AC3,(AC1) ;DEVICE NAME
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
TTCALL 3,[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,777777 ;[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: TTCALL 3,[ASCIZ/ [/] ;[323]
MSVID1: ILDB C,AC1
TLNN AC1,100 ;SKIP IF ASCII [EDIT#304]
ADDI C,40 ;CONVERT SIXBIT TO ASCII [EDIT#304]
TLNN AC1,600 ; EBCDIC?
LDB AC1,PTR.97##(AC1) ; YES
PUSHJ PP,OUTCH. ;OUTPUT TO BUFFER [EDIT#304]
SOJG AC4,MSVID1 ;LOOP 9 TIMES
PUSHJ PP,OUTBF. ;DUMP THE BUFFER
TTCALL 3,[ASCIZ/]/] ;
POPJ PP, ;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: TTCALL 3,[ASCIZ/ REEL /]
ROT AC3,-14
JRST MSDEV1
;MSSLR1+3 [277] IG 22-OCT-73
;ROUTINE TO PRECEDE MESSAGES TO TTY WITH "$" [EDIT#277]
$SIGN: TTCALL 3,[ASCIZ/
$ /] ; [EDIT#277]
POPJ PP, ; [EDIT#277]
;TYPE OUT A SIGNED DECIMAL NUMBER, REMOVING LEADING ZEROES [371]
PUTDEC: JUMPGE AC0,PUTDC1 ;IF NEGATIVE, [371]
TTCALL 3,[ASCIZ "-"] ; TYPE SIGNED AND [371]
MOVMS AC0 ; GET MAGNITUDE [371]
PUTDC1: IDIVI AC0,^D10 ; DIVIDE BY RADIX TO [371]
HRLM