FTN4,L,C C C VERSION 1 / 10 / 76 JRT C C VERSION 9 / 17 / 79 CEJ C THIS VERSION WILL HANDLE DATA FILES SUCH AS THE C QUERY HELP FILE. ALL CHANGES TO JRT'S SDLS4 ARE C DENOTED BY A LINE OF DASHES AS UNDERLINES. C C CCCC C C SOURCE: 24999-18050 C RELOC: 24999-16050 C CCCC PROGRAM SDLS4(3,99),24999-16050 REV.1938 790919 DIMENSION IPRAM(5),IREG(2),IREQ(20),IBUF(1153) DIMENSION ITITL(40),IDBLOK(43),IPBUF(33),IDCB(144),ISIZE(2) DIMENSION IDCB2(144) C INTEGER BATCH INTEGER YES,TPFORM,EOBFL INTEGER PGLABL(19),FILEFL,FNMBR INTEGER FINDF(27),FNAME(3),SC,CR,FTYPE,FSIZE,RECLN INTEGER NBUFR(50) C LOGICAL NWREQ,ECHO,PUN C EQUIVALENCE (X,IREG),(IA,IREG),(IB,IREG(2)) EQUIVALENCE (LU,IPRAM) EQUIVALENCE (TPFORM,ITITL),(IREEL,ITITL(40)) EQUIVALENCE (FNAME,IPBUF(2)),(SC,IPBUF(6)) EQUIVALENCE (CR,IPBUF(10)),(FTYPE,IPBUF(14)) EQUIVALENCE (FSIZE,IPBUF(18)),(RECLN,IPBUF(22)) C DATA BATCH/0/,NFILE/1/ DATA YES/2HYE/ DATA ITITL/35*2H ,2HRE,2HEL,2H #,2H: ,2H / DATA IREQ/20*2H /,ISIZE/-1,0/,FILEFL/-1/ DATA PGLABL/2H0 ,3*2H ,2H P,2HAR,2HT ,2HNU,2HMB,2HER,2H , 1 2H ,2H ,2HTY,2HPE,2H ,2H L,2HAB,2HEL/ DATA NWREQ/.FALSE./,ECHO/.FALSE./,PUN/.FALSE./ C C C STATEMENT FUNCTIONS: C IWORD(I)=IBUF(INDEX+I) C C C C TAKE CARE OF THE AMENITIES FIRST... C CALL RMPAR(IPRAM) IF(LU.EQ.0)LU=1 ILU=LU+400B LLU=LU WRITE(LU,1000) 1000 FORMAT("24999-16050 1938 SOFTWARE SERVICE KIT SYSTEM 1000"/) C WRITE(LU,100) 100 FORMAT(/"/SDLS4: MAG TAPE LU = _") READ(LU,*)MTLU C C TRY TO LOCK THE MAG TAPE C X=LURQ(100001B,MTLU,1) C C C REWIND THE TAPE C 4 CALL EXEC(3,MTLU+400B) C C******************************************************* C C C MAIN LOOP C C 10 IF(BATCH.NE.0)CALL CLOSE(IDCB2,IERR) BATCH=0 IUPFL=0 IREQ=2H WRITE(LU,110) 110 FORMAT(/"/SDLS4: TASK: _") CALL REIO(1,ILU,IREQ,3) IF(IREQ.EQ.2HDI)GO TO 20 IF(IREQ.EQ.2HLO)GO TO 50 IF(IREQ.EQ.2HBA)GO TO 40 IF(IREQ.EQ.2HUP)GO TO 46 IF(IREQ.EQ.2HRE)GO TO 26 IF(IREQ.EQ.2HN )GO TO 87 IF(IREQ.EQ.2HLL)GO TO 85 IF(IREQ.EQ.2HLA)GO TO 21 IF(IREQ.EQ.2HPU)GO TO 8000 IF((IREQ.EQ.2HEN).OR.(IREQ.EQ.2HEX))GO TO 90 IF(IREQ.EQ.2H??)GO TO 200 C C C******************************************************* C C C ERROR SECTION C 11 WRITE(LU,111) 111 FORMAT("/SDLS4: INPUT ERROR!") GO TO 10 C 12 IF(INDEX.NE.0)GO TO 14 WRITE(LU,112) GO TO 10 C 14 IF(INDEX.NE.-4)GO TO 16 WRITE(LU,116)NFILE GO TO 10 C 16 WRITE(LU,117)INDEX GO TO 10 112 FORMAT("/SDLS4: END OF TAPE") 116 FORMAT("/SDLS4: BREAK AT FILE"I5) 117 FORMAT("/SDLS4: ERROR"I4". PLEASE REFER TO LISTINGS...") C 19 WRITE(LU,119)IERR 119 FORMAT("/SDLS4: FILE ERROR"I5) CALL CLOSE(IDCB,IERR) GO TO 10 C C TASK TO REWIND THE TAPE C 26 CALL GETRC(IBUF,MTLU,-3,INDEX,NFILE) GO TO 10 C******************************************************* C C C C DIRECTORY SECTION: C LIST THE ALL PROGRAM I.D. BLOCKS INTO C A SPECIFIED FILE - - FORMATTED FOR LINE PRINTER * DUMP * C 20 ASSIGN 21 TO IRETN WRITE(LU,121) 121 FORMAT("/SDLS4: LIST FILE: _") GO TO 501 C 21 IERR=-2 IF(FILEFL.GT.0)GO TO 19 IF(NFILE.NE.1)CALL GETRC(IBUF,MTLU,-3,INDEX,NFILE) CALL GETRC(IBUF,MTLU,0,INDEX,NFILE) IF(INDEX.LE.0)GO TO 12 IF(IWORD(1).EQ.0)GO TO 23 WRITE(LU,123) 123 FORMAT("/SDLS4: TAPE HAS NO LABEL!! ???") GO TO 26 C C PUT LABEL INFO INTO HEADER FOR LISTING C 23 IBUF(INDEX+16)=2H IBUF(INDEX+25)=2H IBUF(INDEX+31)=2H C DO 24 I=2,34 ITITL(I)=IWORD(I+1) 24 CONTINUE CALL CODE WRITE(IREEL,124)IBUF(INDEX+37) 124 FORMAT(I2) C C IF IT'S A 'LABEL' REQUEST, WE'RE DONE C IF(IREQ.NE.2HLA)GO TO 241 CALL REIO(2,ILU,ITITL,40) GO TO 10 241 CALL GETRC(IBUF,MTLU,0,INDEX,NFILE) IF(INDEX.LE.0)GO TO 12 IF(IWORD(1).NE.-2)GO TO 241 C C SET UP POINTERS... C 25 NLINE=0 TPFORM=2H PGLABL(2)=2HFI PGLABL(3)=2HLE PGLABL(4)=2H C C ID BLOCK LISTING SECTION C 30 IF(FILEFL.EQ.0)GO TO 31 ISIZE=FSIZE IF(ISIZE.EQ.0)ISIZE=-1 ISIZE(2)=RECLN CALL CREAT(IDCB,IERR,FNAME,ISIZE,4,SC,CR) IF(IERR.LT.0)19,33 C 31 CALL OPEN(IDCB,IERR,FNAME,0,SC,CR) IF(IERR.LT.0)GO TO 19 C LOOP C C 33 CALL GETRC(IBUF,MTLU,1,INDEX,NFILE) IF(INDEX)39,38,32 32 IF(IWORD(1).NE.4)GO TO 34 WRITE(LU,130) 130 FORMAT("/SDLS4: END OF DIRECTORY") GO TO 38 C 34 N=NFILE IBUF(INDEX+31)=IOR(IAND(IWORD(13),77400B),40B) IBUF(INDEX+11)=2H IBUF(INDEX+13)=IOR(IAND(IBUF(INDEX+13),77400B),40B) IBUF(INDEX+31)=2H C IF(NLINE/50*50.NE.NLINE)GO TO 36 CALL WRITF(IDCB,IERR,ITITL,40) TPFORM=2H1 CALL WRITF(IDCB,IERR,PGLABL,19) CALL WRITF(IDCB,IERR,PGLABL(11),2) C 36 CALL CODE WRITE(IDBLOK,136)N,(IBUF(INDEX+I),I=3,13),(IBUF(INDEX+J),J=18,44) 136 FORMAT(1X,I4,": "11A2,1X,27A2) CALL WRITF(IDCB,IERR,IDBLOK,43) IF(IERR.LT.0)GO TO 19 NLINE=NLINE+1 GO TO 33 C C END LOOP C 38 CALL WRITF(IDCB,IERR,ITITL,1) IF(IERR.LT.0)GO TO 19 39 CALL LOCF(IDCB,IERR,IREC,IRB,IOFF,ISEC) ITRUN=ISEC/2-IRB-1 CALL CLOSE(IDCB,IERR,ITRUN) IF(INDEX.LE.0)GO TO 12 IF(BATCH)42,10,42 C C******************************************************* C C C INITIATE BATCH MODE OPERATIONS - GET INPUT FILE C C BATCH FILE FORMAT: C C FILE NAME (NAMR) C STOCK NUMBER OR FILE NUMBER (FORWARD SEARCH ONLY IF GIVEN ST #) C . C . C FILE NAME C STOCK NUMBER OR FILE NUMBER C C ALL FIELDS MUST BE LEFT JUSTIFIED C IF A "/E" IS ENCOUNTERED, THE TAPE WILL BE RE-WOUND C C 40 ASSIGN 41 TO IRETN WRITE(LU,140) 140 FORMAT("/SDLS4: ENTER BATCH-FILE NAME: _") GO TO 501 C 41 IF(FILEFL.EQ.-1)GO TO 11 BATCH=1 WRITE(LU,45) 45 FORMAT("ECHO? _") READ(LU,47)IREPLY 47 FORMAT(A2) IF (IREPLY .EQ. 2HYE) ECHO = .TRUE. CALL OPEN(IDCB2,IERR,FNAME,2,SC,CR) IF(IERR.LT.0)GO TO 19 C 42 CALL READF(IDCB2,IERR,IREQ,20,LEN) IF(IERR.LT.0)GO TO 19 IF(LEN.EQ.-1)GO TO 10 IF(IREQ.EQ.2H/E)GO TO 26 IB=LEN ASSIGN 51 TO IRETN GO TO 502 C C C INITIATE 'UPDATE MODE OPERATION': C SIMILAR TO BATCH EXCEPT THAT ONLY TAPE FILES WHOSE REV CODES C ARE GREATER THAT THOSE SPECIFIED IN THE REQUEST BATCH FILE C WILL BE LOADED C 46 IUPFL=1 GO TO 40 C C C*************************************************** C C LOAD / STORE REQUESTS C 50 ASSIGN 51 TO IRETN WRITE(LU,150) 150 FORMAT("/SDLS4: LOAD INTO FILE: _") GO TO 501 C 51 FNMBR=0 DO 552 I=1,20 IREQ(I)=2H 552 CONTINUE IF(BATCH.EQ.0)GO TO 551 CALL READF(IDCB2,IERR,IREQ,8,LEN) IF(IERR.LT.0)GO TO 19 IF(LEN.EQ.-1)11,58 C 551 WRITE(LU,151) 151 FORMAT("/SDLS4: ENTER STOCK # OR FILE #: _") CALL REIO(1,ILU,IREQ,8) 58 IF (NWREQ) GO TO 6999 IF(IAND(IREQ,77400B).EQ.20000B)GO TO 11 IF(IREQ(4).NE.2H )GO TO 60 CALL CODE READ(IREQ,*)FNMBR IF(FNMBR.LE.1)GO TO 11 C C C TAPE SEARCH GIVEN FILE NUMBER C (ASSUME REWIND SPEED = 4 X READ SPEED AND ALL FILES SAME SIZE) C 57 IF(FNMBR.GT.NFILE)GO TO 52 ITIME1=NFILE/4+FNMBR ITIME2=NFILE-FNMBR IF(ITIME2.LT.ITIME1)GO TO 54 C CALL GETRC(IBUF,MTLU,-3,INDEX,NFILE) 52 DO 53 I=1,FNMBR-NFILE CALL GETRC(IBUF,MTLU,-1,INDEX,NFILE) IF(INDEX.LE.0)GO TO 12 53 CONTINUE GO TO 56 C 54 DO 55 I=1,ITIME2+1 CALL GETRC(IBUF,MTLU,-2,INDEX,NFILE) IF(INDEX.LE.0)GO TO 12 55 CONTINUE CALL GETRC(IBUF,MTLU,-1,INDEX,NFILE) IF(INDEX.LE.0)GO TO 12 C C TAPE IS NOW POSITIONED... C 56 CALL GETRC(IBUF,MTLU,0,INDEX,NFILE) IF(INDEX.LE.0)12,711 C C TAPE SEARCH GIVEN STOCK NUMBER (FORWARD SEARCH ONLY) C 60 CALL GETRC(IBUF,MTLU,1,INDEX,NFILE) IF (INDEX .LE. 0) GO TO 12 6999 IF (.NOT.(ECHO)) GO TO 61 DO 7000 I=1,6 7000 NBUFR(I) = IWORD(I+2) WRITE(LU,6000) (IREQ(I),I=1,6),(NBUFR(I),I=1,6) 6000 FORMAT(6A2,4X,6A2) 61 NWREQ = .FALSE. DO 62 I=1,6 IF (IWORD(I+2) .NE. IREQ(I)) GO TO 63 62 CONTINUE GO TO 69 63 DO 64 I=1,6 IF (IWORD(I+2) .GT. IREQ(I)) GO TO 65 IF (IWORD(I+2) .LT. IREQ(I)) GO TO 60 64 CONTINUE 65 NWREQ = .TRUE. GO TO 42 C 69 IF(IREQ(7).EQ.2H )GO TO 70 IF(IUPFL.EQ.0)GO TO 70 C IF(IWORD(9).GT.IREQ(7))GO TO 71 IF((IWORD(9).EQ.IREQ(7)).AND.(IWORD(10).GT.IREQ(8)))71,42 163 FORMAT(9X,"REV CODE DISCREPANCY:") C C CHECK PROG TYPE, FIGURE OUT FILE TYPE, CREATE THE FILE C 70 IF(IREQ(7).EQ.2H )GO TO 711 IDSCRP=IREQ(7)-IWORD(9)+IREQ(8)-IWORD(10) IF(IDSCRP.NE.0)WRITE(LLU,163) C C IF UPDATE MODE, UPDATE THE BATCH-FILE TO HAVE NEW REV CODES C 71 IF(IUPFL.EQ.0)GO TO 711 IREQ(7)=IWORD(9) IREQ(8)=IWORD(10) CALL POSNT(IDCB2,IERR,-1) CALL WRITF(IDCB2,IERR,IREQ,LEN) C 711 ITYPE=IAND(IWORD(12),77400B) ITYPE=ITYPE+ITYPE/256 FTYPE=0 IF(ITYPE.EQ.2HSS)FTYPE=4 IF(ITYPE.EQ.2HRR)FTYPE=5 IF(ITYPE.EQ.2HAA)FTYPE=7 IF(ITYPE.EQ.2HDD)FTYPE=1 C------------------------------------------------------------ IF(FTYPE.NE.0)GO TO 72 WRITE(LU,170)ITYPE 170 FORMAT("/SDLS4: ILLEGAL PROGRAM TYPE: "A2) GO TO 10 C 72 WRITE(LLU,172)(FNAME(I),I=1,3),(IBUF(INDEX+I),I=3,10), & (IBUF(INDEX+I),I=18,44) 172 FORMAT(1X,3A2,": ",8A2,1X,27A2) N = 1 DO 175 I=3,10 NBUFR(N) = IBUF(INDEX+I) 175 N = N+1 NBUFR(N) = 2H N = N + 1 DO 176 I=18,44 NBUFR(N) = IBUF(INDEX+I) 176 N = N+1 NBUFR(N) = 0 IF(FILEFL.NE.-1)GO TO 74 ISIZE=FSIZE ISIZE(2)=RECLN IF(ISIZE.EQ.0)ISIZE=-1 CALL CREAT(IDCB,IERR,FNAME,ISIZE,FTYPE,SC,CR) IF(IERR.LT.0)19,75 C 74 CALL OPEN(IDCB,IERR,FNAME,0,SC,CR) IF(IERR.LT.0)GO TO 19 IF((FILEFL.NE.-1).AND.(IERR.GT.0))WRITE(LLU,174)FNAME 174 FORMAT(9X"DUPLICATE FILE NAME - - "3A2) FILEFL=IERR C C LOOP READ TAPE, LOAD FILE C C CHECK THE DATA TYPE (IWORD(1)): C TYPE C A) EOB BLOCKS => WRITE 0-LENGTH RECORD * 3 C B) EOF BLOCKS => WRITE EOF 4 C C) DATA BLOCKS => THAT'S FINE!!! -1 C D) PHYSICAL EOF => DONE! -2 C E) ELSE => ERROR C C * EXCEPT THE FIRST AND LAST ONES C C C ALSO, CHECK GETRC STATUS (INDEX): C C ANY ERROR (OR BREAK) ENCOUNTERED DURING PROGRAM LOAD WILL C RESULT IN THE LOAD FILE BEING PURGED (EXCEPT IF TYPE 0) AND C THE TAPE BEING POSITIONED BACK TO THE START OF THAT FILE C C IF ((FILEFL .NE. 0) .OR. (.NOT.(PUN))) GO TO 700 CALL ALPHA (NBUFR,LUP) 700 IRECN=0 75 CALL GETRC(IBUF,MTLU,0,INDEX,NFILE) IF(INDEX.LE.0)GO TO 80 NWDS=IBUF(INDEX) IF(IWORD(1).NE.4)GO TO 755 CALL WRITF(IDCB,IERR,IBUF,-1) GO TO 75 755 IF(IWORD(1).NE.3)GO TO 76 756 IF(IRECN.NE.0)EOBFL=1 GO TO 75 76 IF(IWORD(1).EQ.-2)GO TO 77 IF(EOBFL.NE.0)CALL WRITF(IDCB,IERR,IBUF,0) EOBFL=0 IF(IWORD(1).NE.-1)GO TO 78 C IF(NWDS.EQ.0)GO TO 756 IRECN=1 CALL WRITF(IDCB,IERR,IBUF(INDEX+2),NWDS) IF(IERR.LT.0)19,75 C C EOF FOUND C 77 WRITE(LU,177) 177 FORMAT("/SDLS4: LOAD COMPLETE") GO TO 39 C C RECORD OUT OF SEQUENCE C 78 INDEX=-14 C C BREAK DURING LOAD: PURGE ACTIVE FILE (UNLESS TYPE 0) C SET TAPE TO START OF CURRENT FILE C 80 CALL CLOSE(IDCB,IERR) IF(FILEFL.EQ.0)GO TO 81 CALL PURGE(IDCB,IERR,FNAME,SC,CR) IF(IERR.LT.0)GO TO 19 81 CALL GETRC(IBUF,MTLU,-2,IDUMY,NFILE) C-----------------------------------------IDUMY INSTEAD OF INDEX CALL GETRC(IBUF,MTLU,-1,IDUMY,NFILE) C-----------------------------------------NO MORE 129 ERRORS! GO TO 12 C C******************************************************** C C PRINT CURRENT FILE NUMBER C 87 WRITE(LU,187)NFILE 187 FORMAT("/SDLS4: CURRENT MAG TAPE FILE ="I5) GO TO 10 C C CHANGE LOG LU C 85 WRITE(LU,185) 185 FORMAT("/SDLS4: ENTER LOG LU: _") READ(LU,*)LLU GO TO 10 C C PRINT ALL SDLS4 COMMANDS C 200 WRITE(LU,219) WRITE(LU,201) WRITE(LU,203) WRITE(LU,205) WRITE(LU,206) WRITE(LU,207) WRITE(LU,209) WRITE(LU,211) WRITE(LU,212) WRITE(LU,213) WRITE(LU,214) WRITE(LU,202) WRITE(LU,204) WRITE(LU,206) WRITE(LU,208) WRITE(LU,215) WRITE(LU,216) WRITE(LU,218) WRITE(LU,217) 219 FORMAT(/" TASK FUNCTION"/) 201 FORMAT("LABEL PRINT TAPE LABEL") 203 FORMAT("DIRECTORY LIST ALL FILE IDENTIFICATION ON TAPE") 205 FORMAT("REWIND REWIND THE TAPE") 207 FORMAT("N PRINT CURRENT FILE POSITION NUMBER") 209 FORMAT("LL CHANGE THE LOG DEVICE, LU # WILL BE ASKED") 211 FORMAT("LOAD LOAD A FILE FROM THE TAPE TO DISC") 212 FORMAT(" NAME & PART # OR FILE # WILL BE ASKED") 213 FORMAT("BATCH GET LOAD COMMANDS FROM A FILE") 214 FORMAT(" TAPE FORMAT: NAMR") 202 FORMAT(" PART # OR FILE #") 204 FORMAT(" NAMR") 206 FORMAT(" .") 208 FORMAT(" /E TERMINATES THE COMMANDS") 215 FORMAT("UPDATE SAME AS BATCH,BUT MUST USE PART #. IT LOADS") 216 FORMAT(" FILES WITH LATER REV THAN THAT SPECIFIED IN") 218 FORMAT(" COMMAND FILE") 217 FORMAT("END/EXIT EXIT FROM SDLS4") GO TO 10 C C C********************************************************* C C C 'SUBROUTINE' TO OPEN AND CREATE REQUIRED FILES C C NOTES: INPUTS 'NAMR' C TRIES AN EXCLUSIVE OPEN ON THE FILE C IF IT EXISTS AS TYPE 1, CLOSE IT 'TILL NEEDED C IF NON-EXISTANT, FLAG IT AS 'NEEDED' C ( WHY TIE UP A FILE (OR DISC) IF YOU HAVE TO SEARCH THE TAPE FIRST) C 501 DO 511 I=1,20 IREQ(I)=2H 511 CONTINUE X=REIO(1,ILU,IREQ,20) 502 DO 504 I=1,IB IF(IAND(IREQ(I),77400B).NE.35000B)GO TO 503 IREQ(I)=IOR(IAND(IREQ(I),377B),26000B) 503 IF(IAND(IREQ(I),177B).NE.72B)GO TO 504 IREQ(I)=IOR(IAND(IREQ(I),177400B),54B) 504 CONTINUE C IB=IB*2 CALL PARSE(IREQ,IB,IPBUF) IF(IPBUF.LE.1)GO TO 11 C FILEFL=-1 CALL OPEN(IDCB,IERR,FNAME,0,SC,CR) IF(IERR.GE.0)GO TO 512 IF(IERR.NE.-6)GO TO 19 GO TO IRETN C 512 FILEFL=IERR CALL CLOSE(IDCB,IERR) GO TO IRETN C 8000 WRITE(LU,8010) 8010 FORMAT("PUNCH LU FOR LABEL IS? _") READ(LU,*)LUP PUN = .TRUE. GO TO 10 C********************************************************** C C C END SECTION REWIND TAPE AND UNLOCK THE LU C C 90 CALL GETRC(IBUF,MTLU,-3,INDEX,NFILE) CALL LURQ(100000B,MTLU,1) 990 WRITE(LU,190) 190 FORMAT("/SDLS4: DONE!"/) C END ASMB,R,B,L,C * NAM GETRC,7 VERSION 2 REV.1938 790919 * * THIS VERSION WILL HANDLE DATA FILES SUCH AS THE QUERY * HELP FILE. ALL CHANGES MADE TO JRT'S GETRC FOR THIS * FEATURE ARE DENOTED BY A LINE OF DASHES AS UNDERLINES. * * ENT GETRC EXT EXEC,.ENTR,IFBRK * * * * * CALLING INFORMATION: * * IFLAG: -3 REWIND THE TAPE * -2 REVERSE 1 FILE (SET TAPE TO PREVIOUS FILE) * -1 FORWARD FILE (FIND EOF) * 0 FIND NEXT SEQUENTIAL RECORD * 1 FIND PROGRAM ID BLOCK * 2 FIND LIBRARY DIRECTORY RECORD * 3 FIND EOB BLOCK * 4 FIND AN EOF BLOCK * ELSE REWIND & START ALL OVER.... * * * IBUF IS 1153 WORDS LONG AND RESIDENT IN THE CALLING PROGRAM. * GETRC READS INTO IBUF FROM MAG TAPE (MTLU) AND SETS 'INDEX' * TO POINT TO THE DESIRED ITEM (RECORD). RECORD STRUCTURE ON * THE MTLS TAPE IS A HIERARCHY OF DATA RECORDS => LOGICAL RECORDS * => PHYSICAL RECORDS. GETRC KEEPS TRACK OF THIS CRAP. * WHEN DATA RECORDS ARE SPLIT BETWEEN TWO PHYSICAL MAG TAPE RECORDS * GETRC WILL MOVE THE FIRST PORTION OF THE RECORD INTO LOW-INDEXED * PART OF 'IBUF' THEN READ THE NEXT MAG TAPE RECORD TO GET THE REST * OF THE DATA RECORD. THIS IS WHY 'IBUF' MUST BE 1153 WORDS LONG * EVEN THOUGH THE LARGEST MAG TAPE RECORD IS 1024 WORDS. THE * ROUTINE USES "CFLAG" AS A FLAG TO INDICATE A RECORD REQUIRES * CONTINUATION. MAG TAPE RECORDS ARE READ INTO 'IBUF' STARTING * AT IBUF(129) IN ORDER TO LEAVE ROOM FOR A POSSIBLE MOVE AS * DESCRIBED HERE. * * * GETRC RETURNS THE CURRENT PHYSICAL FILE NUMBER IN 'NFILE' * * RETURN FORMAT IN 'IBUF': * * IBUF(INDEX) = LENGTH OF DATA RECORD * IBUF(INDEX+1) = RECORD TYPE 1-4 AS ABOVE * 0 = TAPE LABEL RECORD * -1 = DATA RECORD * -2 = PHYSICAL EOF ENCOUNTERED * IBUF(INDEX+2) = FIRST DATA WORD * * * SKP * * * * RETURN FORMAT FOR 'INDEX': * * -14 = RECORD OUT OF SEQUENCE * -13 = ILLEGAL PROGRAM TYPE * -12 = DATA RECORD LENGTH > 255 * -11 = INTERNAL ERROR SEE LISTING * -10 = INTERNAL ERROR SEE LISTING * -9 = INTERNAL ERROR SEE LISTING * -8 = LOGICAL RECORD LENGTH ERROR * -7 = ILLEGAL RECORD LENGTH * -6 = LOGICAL RECORD OUTSIDE OF PHYSICAL BOUNDS * -5 = INTERNAL ERROR SEE LISTING * -4 = BREAK FLAG WAS SET * -3 = ILLEGAL LOGICAL RECORD TYPE * -2 = CHECKSUM ON DATA RECORD * -1 = CHECKSUM ERROR ON PHYSICAL RECORD * 0 = END OF TAPE * >0 = POINTER INTO IBUF FOR DESIRED RECORD * * NOTES: IPOINT IS LOCAL BUFFER POINTER * PMAX POINTS TO END OF LOGICAL RECORD * NMAX POINTS TO END OF PHYSICAL RECORD * LRLNTH IS LENGTH OF LOGICAL RECORD * * * * * SKP * * * IBUF BSS 1 MTLU BSS 1 IFLAG BSS 1 INDEX BSS 1 NFILE BSS 1 * GETRC NOP JSB .ENTR DEF IBUF * * SET UP OFT-USED ADDRESSES INTO DATA BUFFER * LDA IBUF ADA D128 SET ADDRESS OF START OF ACTIVE STA IB129 PART OF DATA BUFFER INA STA IB130 AND NEXT WORD,TOO. * LDA D129 SET RETURN-POINTER TO START OF STA INDEX,I DATA ARRAY AS WELL. LDA IFLAG,I CHECK FOR 'QUICKIE'S 1ST CPA DM3 JMP RWIND -3 = REWIND THE TAPE CPA DM2 JMP RVFIL -2 = REVERSE 1 FILE CPA DM1 JMP FWFIL -1 = FORWARD ONE FILE SSA IFLAG CAN'T BE <-3 OR >4... JMP RWIND ELSE TAPE REWINDS ADA DM5 SSA JMP PHYSR IF O.K., GET A DATA RECORD * *q * * SKP * * RWIND LDA B400 REWIND CODE... JSB TAPE GO DO IT... CLA,INA RESET MAG TAPE FILE # TO 1 STA FILE RTRN0 CLA '0' RETURN POINT (EOF RETURN) STA PMAX RESET ALL LOCAL POINTERS STA NMAX STA BPNTR LDA DM2 SET DATA WORD 2 = -2 STA IB130,I AS INDICATION OF EOF * RTRN1 LDA FILE '1' RETURN, PASS RESULTS TO CALLER STA NFILE,I JSB BCHK CHECK BREAK FLAG JMP GETRC,I * * REVERSE 1 FILE ON THE TAPE * RVFIL LDA B1400 REV FILE CODE JSB TAPE GO DO IT... LDA B1400 GO DO IT AGAIN... JSB TAPE LDA FILE ADA DM2 RESET THE FILE COUNTER SZA,RSS IF FILE # <=0 SET IT CLA,INA EQUAL TO 1 SSA CLA,INA STA FILE ELSE, IT'S O.K. * * FORWARD SPACE ONE FILE * FWFIL LDA B1300 FORWARD FILE CODE JSB TAPE GO DO IT... ISZ FILE INCREMENT FILE COUNTER JMP RTRN0 RETURN THRU 'EOF RETURN' * * SKP * * * START LOOKING FOR A TAPE DATA RECORD HERE * PHYSR LDA BPNTR IF LOCAL POINTER IS WITHIN LDB NMAX DATA BUFFER BOUNDS, THEN WE DON'T JSB .GE. NEED A PHYSICAL TAPE READ YET... SEZ,RSS JMP LR.1 SO GO GET THE NEXT LOGICAL RECORD! * PHSR2 JSB BCHK IF NEED A TAPE READ, CHECK BREAK LDA D129 FLAG FIRST. ALL O.K., PRESET RETURNED STA INDEX,I POINTER. RESET LOCAL RECORD CLA POINTERS ALSO. STA PMAX STA NMAX * JSB EXEC GO GET THAT MOTHA!!! DEF *+5 DEF ONE DEF MTLU,I IB129 NOP DEF D1024 STB TLOG SAVE TRANSMISSION LOG (AAMCO TOOT TOOT) * JSB EXEC IS IT AN EOF? DEF *+4 DEF D13 DEF MTLU,I DEF ISTAT * LDA ISTAT AND B200 SZA,RSS JMP GOT1 IF NOT AN EOF, PROCESS THE RECORD! * * EOF PROCESSING * LDA DM2 SET IBUF(130) = -2 TO SIGNAL CALLER STA IB130,I ISZ FILE INCREMENT FILE COUNTER ISZ EOTFL COUNT # OF EOF'S IN A ROW... JMP PCNT1 IF NOT 2 IN A ROW, CONTINUE CLA ELSE CLEAR EOF FLAG AND SIGNAL STA INDEX,I CALLER THAT THIS IS IT!!! STA EOTFL RESET EOT FLAG JMP RTRN1 TAPES ALL DONE!!! * PCNT1 CCA GOT 1 EOF, GET SET FOR STA EOTFL POSSIBLE NEXT ONE. LDA IFLAG,I IF OP CODE = 0 (FIND NEXT SZA,RSS SEQUENTIAL RECORD) THEN RETURN. JMP RTRN1 IF HE WANTS SOMETHING SPECIAL JMP PHSR2 GO TRY AGAIN * SKP * * * START PROCESSING MAG TAPE RECORDS HERE... * * CHECK TAPE RECORD'S CHECKSUM * GOT1 STA EOTFL RESET EOT FLAG LDA TLOG CHECK THAT RECORD WAS < 1024 LDB D1024 JSB .LE. SEZ JMP CHK.1 ALL'S O.K. GO TO CHK.1 LDA DM7 ELSE, -7 = ERROR CODE! .BAD STA INDEX,I THIS IS BAD GUY RETURN! JMP RTRN0 NOW TO 'EOF RETURN'! * CHK.1 LDB IB130 = DATA ADDRESS START LDA IB129,I GET SIO COUNT ARS CHANGE TO WORD COUNT ADA IB129 ADD STARTING ADDRESS STA END = END = DATA ADDRESS END LDA B,I SET UP CHECKSUM STA CHKSM LOOP1 INB INCREMENT ADDRESS CPB END = LAST ADDRESS? JMP CHK.2 YES, CHECK CHECKSUMS ADA B,I NO, KEEP ADDING.... JMP LOOP1 DO IT AGAIN, DO IT AGAIN, DO IT... * CHK.2 CPA B,I OURS = THEIRS??? JMP PH.OK YES, PHYS. RECORD O.K. CCA NO, FUCK YOU!!! JMP .BAD * PH.OK STB NMAX SAVE 'END' AND MAX PHYS REC LDA IB130 ADDRESS. RESET WORK POINTER STA BPNTR * * SKP * * * START PROCESSING LOGICAL RECORDS HERE... * * THERE'S A LOT OF CHECKING TO DO: * 1) MAYBE WE ONLY NEED A DATA RECORD (ASCII LINE, ABSOLUTE RECORD * ETC.). IF WE ACTUALLY DO NEED A NEW LOGICAL RECORD GO TO '3)' * ELSE WE'RE STILL PROCESSING THE PREVIOUS ONE AND... * 2) IF WE'RE HERE, WE HAVE PROGRAM DATA SINCE MTLS INFO-RECORDS * MUST BY DEFINITION BE PROCESSED COMPLETELY BEFORE ASKING FOR * A NEW ONE. THUS, IF THE OP-CODE (IFLAG IN CALL) IS NOT A * REQUEST FOR NEXT-SEQUENTIAL-RECORD (0) IT IS FOR AN MTLS * RECORD AND THEREFOR EVEN IF WE ARE NOT DONE WITH THIS ONE WE * NEED A NEW ONE ANYHOW (GO TO '3)') ELSE GO PROCESS DATA... * 3) IF WE'RE DONE WITH THE LOGICAL RECORD SEE IF THERE'S ANOTHER * ALREADY IN MEMORY. IF NOT, GO GET ANOTHER MAG TAPE RECORD * (PHYSICAL READ VS. LOGICAL READ) * 4) THE LOGICAL RECORD LENGTH SHOULD BE CONSISTENT WITH PHYSICAL * RECORD BOUNDS. AS OF 4/75, THERE ARE MTLS TAPES OUT WITH ERRORS * IN PROGRAM ID BLOCK RECORDS (THEY'RE MISSING A WORD) SO THIS * CHECK CAN'T BE DONE YET. * 5) CHECK LOGICAL RECORD TYPE. IF IT'S AN MTLS RECORD, IT'S LENGTH * SHOULD AGREE WITH THE TABLE VALUES (SEE 'LNTAB') * * LR.1 LDA BPNTR LDB PMAX = BPNTR . IF WORK POINTER EXCEEDS JSB .GE. LOG REC POINTER, SO NEED A SEZ NEW LOGICAL RECORD. ELSE WE JMP GETLR GOT DATA. CHECK THAT OP-CODE LDA IFLAG,I IS 0, OR ELSE WE NEED A SZA NEW LOGICAL RECORD. JMP NXTLR LDA PRGTP PROCESS DATA ACCORDING TO CPA SS PROGRAM TYPE (S, R, OR ABS) JMP SRC.2 IF TYPE = 'SS', HAVE SOURCE. JMP REL.1 ELSE CHECK FOR RELOCATABLE... * * SKP * * * GET A NEW LOGICAL RECORD * GETLR LDA BPNTR NEED A PHYSICAL RECORD FIRST? LDB NMAX (I.E. IS WORK POINTER OUT OF BOUNDS) JSB .GE. SEZ JMP PHSR2 YES, GET ONE * LDA BPNTR,I NO, GET LR RECORD LENGTH CMA,INA STA LRLNT SAVE IT. SSA,RSS IF (-) = WORDS JMP *+5 IF(+) = CHARACTERS. CONVERT CMA,INA TO (+) WORDS INA ARS STA LRLNT SAVE IT INA SET PMAX = POINTER + LENGTH + 1 ADA BPNTR STA PMAX THIS IS MAX LR ADDRESS * * TAKE AWAY *'S TO ENABLE THIS SECTION * * LDB NMAX IF LR BOUND EXCEEDS PHYS REC * JSB .GT. BOUND, THEN NO GOOD! * SEZ SET EOF (THIS SHOULD MUCK THINGS UP! * JMP RTRN0 * SKP * * * PROCESS A NEW LOGICAL RECORD... * * IF LENGTH >= 0 HAVE A DATA RECORD: SOURCE * RELOCATABLE * ABSOLUTE * * LENGTH < 0 & WE HAVE AN MTLS-INFO RECORD * * WORD 2 MEANING LENGTH * 0 TAPE LABEL 37 * 1 PROGRAM I.D. BLOCK 129 * 2 LIBRARY DIRECTORY 129 * 3 EOB BLOCK 1 * 4 EOF BLOCK 3 * * *-------------------------------------------------------------- * * THERE IS A PROBLEM HERE, HOWEVER, SINCE A DATA TYPE FILE MAY * CONTAIN NEGATIVE DATA WHERE THIS PROGRAM THINKS IT HAS A LENGTH * WORD. SO, IF BPNTR DOES NOT POINT TO IB130 AND PROGRAM TYPE * IS DD AND IFLAG IS ZERO, SKIP DIRECTLY TO SRC.1. * *------------------------------------------------------------- * * LDA BPNTR *-------------------------------------------------------------- CPA IB130 *--------------------------------------------------------------- JMP ROKAY *--------------------------------------------------------------- LDA PRGTP *--------------------------------------------------------------- CPA DD *--------------------------------------------------------------- RSS *--------------------------------------------------------------- JMP ROKAY *--------------------------------------------------------------- LDA IFLAG,I *--------------------------------------------------------------- SZA,RSS *--------------------------------------------------------------- JMP SRC.1 *--------------------------------------------------------------- * ROKAY LDA BPNTR,I GET LENGTH AGAIN *---------------------------------------NEW LABEL SSA IF < 0, PROCESS MTLS STUFF JMP .MTLS (CHECK IT FIRST...) LDA IFLAG,I CHECK OP-CODE: MUST BE = 0! SZA,RSS OR GET A NEW LOGICAL RECORD JMP SRC.1 IF = 0, WE HAVE DATA, O.K. JMP NXTLR ELSE GET NEXT LOGICAL RECORD. * * SKP * * * PROCESS MTLS-INFO RECORDS * .MTLS CLA RESET 'CONTINUATION' FLAG STA CFLAG SO WE KNOW THAT NEXT DATA LDA BPNTR RECORD IS A NEW ONE... INA LDA A,I GET RECORD TYPE STA RECTP SAVE IT CPA IFLAG,I IS IT WHAT HE WANTS? JMP GOTIT YES, GO TO IT BABY!!! LDB IFLAG,I NO, WILL HE TAKE ANYTHING? SZB,RSS YES, WE GOT THAT, TOO! JMP GOTIT * NXTLR LDA PMAX GET NEXT LOGICAL RECORD STA BPNTR RESET WORK POINTER JMP GETLR GO THRU NORMAL CHANNELS. * * * SKP * * * * PROCESS MTLS INFO RECORDS * * * GOTIT CPA FOUR IF WITHIN 0 TO 4, O.K. JMP *+6 AND THREE CPA RECTP JMP *+3 LDA DM3 ELSE ERROR CODE = -3 JMP .BAD * ADA LNTAB INDEX INTO LENGTH TABLE LDA A,I AND VERIFY RECORD LENGTH CPA LRLNT IF AGREE, ALL'S WELL... JMP M.OK LDB BPNTR EXECEPTION!: THE LAST PROG ADB THREE ID BLOCK IN THE LIBRARY IS LDB B,I A SHORT ONE INDICATING THE END CPB .99 OF THE LIBRARY. IT'S FOR JMP M.OK PART NUMBER 99999-99 ETC LDA DM8 ELSE ERROR CODE = -8 JMP .BAD * M.OK STA BPNTR,I SET POINTERS, ETC: LDA IBUF SET (+) LR LNTH IN BUFFER CMA,INA SET 'INDEX' = INDEX INTO ARRAY ADA BPNTR SET LOCAL POINTER = PMAX INA SO NEXT ROUND GETS NEW RECORD STA INDEX,I IF HAVE ID BLOCK, SAVE PROG TYPE LDA PMAX RETURN TO CALLER LDB BPNTR STA BPNTR LDA RECTP CPA ONE RSS JMP RTRN1 * ADB TWELV GET PROG TYPE CHARACTER LDA B,I ISOLATE IT & DUPLICATE IT AND UPPER SO IT'S 'SS' OR 'AA' OR 'RR' STA B BLF,BLF IOR B STA PRGTP SAVE IT JMP RTRN1 RETURN * * SKP * * * PROCESS PROGRAM DATA * * SRC.1 ISZ BPNTR POINT TO DATA INFO LDA PRGTP CPA SS IS IT SOURCE DATA? RSS JMP REL.1 NO, CHECK FOR RELOCATABLE * * * SOURCE RECORDS (THE WORST) * * PHYSICALLY MOVE 'EM FROM WHERE THEY ARE (IBUF(129) OR ABOVE) TO * LOW IN THE BUFFER (IBUF(1)). GOTTA DO THIS 'CAUSE CR & LF NOT * NECESSARILY IN THE SAME WORD. SDLS (VS. MTLS) DOES SOME CLEANUP Px * OF TAPE RECORDS TO TRY TO HAVE THAT, BUT IT CAN'T BE GUARANTEED... * ALSO, PREFACE THE RECORD WITH FAKE LENGTH AND TYPE TO MAINTAIN * FORMAT COSISTENCY WITH MTLS-INFO RECORDS. * * * NOTES BBYTE: SOURCE/DESTINATION BYTE * DBYTE: POINTERS * DPNTR: DESTINATION BUFFER ADDRESS * LFFLG: LINE-FEED FLAG * * LDA B177 XOR SHIFT RE-SET: SOURCE BYTE POINTER STA BBYTE LINE FEED FLAG CLA CONTINUATION FLAG STA LFFLG LDB CFLAG IF IT'S NOT A CONTINUATION, RESET STA CFLAG THE DESTINATION BYTE POINTER AND SZB ADDRESS POINTER JMP SRC.3 SRC.2 LDA TWO NOTE: CONTINUATION OCCURS WHEN ADA IBUF A DATA RECORD IS SPLIT 'TWIXT STA DPNTR TWO MAG TAPE RECORDS. LDA B177 STA DBYTE * * SKP * * * * LOOP FOR PROCESSING SOURCE CODE * SRC.3 LDA BPNTR IF WE'RE OUT OF THE BUFFER LDB PMAX WE NEED A NEW RECORD JSB .GE. SEZ,RSS JMP SRC.4 CLA,INA STA CFLAG SET CONTINUATION FLAG JMP GETLR GO GET A RECORD * SRC.4 LDA BPNTR,I GET BYTE W/O PARITY AND BBYTE STA B AND DBYTE HAVE TO SHIFT IT? SZA IE. DO WE WANT THE CHAR WHERE BLF,BLF 'DBYTE' AIN'T? LDA B IF SO, SHIFT ALREADY! CPA HI.CR IGNORE IT IF IT'S RSS A CARRIAGE RETURN CPA LO.CR JMP IGNOR CPA HI.LF IF IT'S A LINE FEED THEN RSS MAKE IT A SPACE AND SET CPA LO.LF THE LINE FEED FLAG RSS JMP STUFF ELSE STUFF IT IN BUFFER ALS,ALS LINE UP LF BITS WITH SPACE AND DBLSP (DON'T KNOW HI OR LO) STA LFFLG STUFF STA CHAR SAVE THE CHARACTER * LDA DBYTE GET GOOD BYTE FROM DESTINATION AND DPNTR,I IOR CHAR INSERT NEW CHARACTER STA DPNTR,I PUT IN DESTINATION BUFFER * LDA DBYTE RESET BYTE POINTERS XOR SHIFT STA DBYTE SLA ISZ DPNTR * * * SKP * * IGNOR LDA BBYTE SET UP NEXT SOURCE BYTE XOR SHIFT MASK STA BBYTE IF GETTING HIGH BITS NEXT, SLA,RSS INCREMENT WORD POINTER. ISZ BPNTR * LDA LFFLG GET A LINE FEED? SZA,RSS JMP SRC.3 NO, LOOP SOME MORE CLA YES, RESET THE FLAG STA LFFLG SET THE RECORD LENGTH LDA IBUF ADA TWO (2 FOR LENGTH & TYPE) CMA,INA ADA DPNTR STA IBUF,I * LDB IBUF RETURN RECORD TYPE INB CCA STA B,I CLA,INA SET POINTER = 1 STA INDEX,I JMP RTRN1 RETURN... * * SKP * * * RELOCATABLE & ABSOLUTE RECORDS * * REL.1 LDA CFLAG IS IT A CONTINUATION? SZA,RSS JMP REL.2 NO, CONTINUE NORMALLY LDA TEMP1 YES, RESET TEMP VALUES STA BPNTR LDA TEMP2 STA IB129,I OVERWRITE OLD SIO COUNTS WITH LDA TEMP3 NEW DATA STA IB130,I CLA STA CFLAG * *REL.2 LDB PMAX *--------------REMOVED FOR PROCESSING OF DATA TYPE REL.2 LDA PRGTP IS THIS A DATA FILE? *--------------------------------------------------------------- CPA DD *--------------------------------------------------------------- JMP DAT.1 YES, GO PROCESS DATA TYPE. *--------------------------------------------------------------- LDB PMAX * --------REPLACING INSTRUCTION REMOVED ABOVE LDA BPNTR,I GET ADDRESS OF FIRST NON- SZA ZERO WORD (RECORD LENGTH) JMP REL.3 GOT IT! GO PROCESS ISZ BPNTR CPB BPNTR IF RUN OUT OF DATA, GO JMP GETLR GET ANOTHER RECORD JMP REL.2+1 ELSE KEEP LOOKING * REL.3 AND UPPER ISOLATE WORD COUNT CPA BPNTR,I A LEGITIMATE VALUE? JMP *+3 LDA DM12 NO, ERROR CODE = -12 JMP .BAD ALF,ALF GET BITS WHERE THEY BELONG.. STA RECLN YES, SAVE RECORD LENGTH LDB PRGTP PROG TYPE ABSOLUTE? CPB AA RSS JMP REL.4 NO, GO PROCESS RELOCATABLE * * SKP * * * ABSOLUTE RECORDS * * ADA BPNTR IF RECORD IS NOT ENTIRELY ADA TWO IN MEMORY, GO DO CONTINUATION STA END TRICK. ELSE PROCESS INA LDB PMAX JSB .GE. SEZ JMP CNTNU * LDB BPNTR CHECK THE RECORD'S CHECKSUM INB LDA B,I ABS.2 INB CPB END JMP ABS.3 ADA B,I JMP ABS.2 ABS.3 CPA B,I CHECKSUMS AGREE? JMP ABS.4 YES, GO ON... LDA DM2 NO, ERROR CODE = -2 JMP .BAD * ABS.4 LDA BPNTR SET TYPE - -1 ADA DM1 CCB STB A,I I@ ADA DM1 LDB RECLN SET LENGTH = ABS RECORD ADB THREE RECORD-LENGTH STB A,I LDA IBUF SET INDEX INTO ARRAY CMA,INA ADA BPNTR ADA DM1 STA INDEX,I ADB BPNTR RESET POINTER FOR NEXT RECORD STB BPNTR JMP RTRN1 RETURN * * SKP * * * PROCESS RELOCATABLE RECORDS * * REL.4 CPB RR IS PROG TYPE RELOCATABLE? JMP *+3 YES, CONTINUE LDA DM13 ELSE ERROR CODE = -13 JMP .BAD SOCK IT TO 'IM!!! ADA BPNTR IS RECORD ENTIRELY WITHIN STA END MEMORY? LDB PMAX JSB .GE. SEZ JMP CNTNU NO, GO GET CONTINUATION * LDA BPNTR INA LDB A,I GET 1ST VALUE INA LOOPR INA CPA END JMP REL.5 ADB A,I JMP LOOPR * REL.5 LDA BPNTR ADA TWO CPB A,I CHECKSUMS AGREE? JMP *+3 LDA DM2 NO, ERROR CODE = -2 JMP .BAD * ADA DM3 CCB STB A,I ADA DM1 LDB RECLN STB A,I CMA,INA ADA IBUF CMA,INA INA STA INDEX,I LDA BPNTR ADA RECLN STA BPNTR JMP RTRN1 RETURN TO CALLER * * SKP **----------------------------------------------------------- ** ** THIS WHOLE SECTION WAS ADDED FOR PROCESSING OF DATA ** TYPE FILES. THE UNDERSCORING IS DISCONTINUED DURING ** THIS SECTION. THE SECTION ENDS WITH THE SKP INSTRUCTION ** IMMEDIATELY PRECEDING THE CONTINUATION SECTION. ** **----------------------------------------------------------- * * * PROCESS DATA FILE RECORDS * * DAT.1 LDA D128 GET DATA RECORD LENGTH STA RECLN ADA BPNTR IF RECORD IS NOT ENTIRELY STA END IN MEMORY, LDB NMAX CPA B (IF SAME ALL OKAY) JMP DAT.2 JSB .GE. SEZ JMP CNTNU GO GET CONTINUATION. * * END OF FILE IS SIGNIFIED ON DATA FILES BY 2 DC3 CHARACTERS IN THE * FIRST WORD OF THE CURRENT LOGICAL RECORD. CHECK FOR THIS. IF * IT IS AN END OF FILE, RETURN WITH TYPE = -2 INSTEAD OF -1. * DAT.2 LDA BPNTR,I CPA .2DC3 RSS JMP DAT.3 LDA BPNTR END OF FILE, ADA DM1 SET TYPE TO -2 LDB DM2 STB A,I JMP DAT.4 AND CONTINUE WITH PROCESSING. * DAT.3 LDA BPNTR SET TYPE = -1 ADA DM1 CCB STB A,I DAT.4 ADA DM1 SET RECORD LENGTH = 128 LDB RECLN STB A,I LDA IBUF SET INDEX INTO ARRAY CMA,INA ADA BPNTR ADA DM1 STA INDEX,I ADB BPNTR RESET POINTER FOR NEXT RECORD STB BPNTR JMP RTRN1 RETURN * * SKP SKP * * * * RECORD CONTINUATION SECTION * CNTNU LDA PMAX CHECK IF THIS IS REALLY LDB NMAX NECESSARY JSB .GE. LDA DM9 SET ERROR CODE = -9 SEZ,RSS JMP .BAD * ADA DM1 SHOULD NOT HAVE CONTINUATION HERE. LDB CFLAG SZB JMP .BAD * ADA DM1 PRESET ERROR = -11 LDB BPNTR MUST NOW MOVE EXISTING DATA CMB,INB OUT OF THIS AREA INTO LOW BUFFER. ADB NMAX BUT ONLY FAR ENOUGH SO THAT STB NMOVE IT'LL BE CONTIGUOUS WITH CMB,INB NEW DATA TO BE READ IN. THIS ADB D131 PART CHECKS THAT THE MOVE IS SSB ENTIRELY WITHIN THE BUFFER. JMP .BAD * LDA NMOVE CMA,INA SAVE AS START, NEXT TIME. ADA IB130 CLACULATE END OF MOVE INA STA TEMP1 STA DPNTR LDB BPNTR LOOPM LDA B,I MOVE-LOOP... STA DPNTR,I ISZ DPNTR INB CPB PMAX RSS JMP LOOPM * LDA IB129,I SAVE DATA IN WORD-COUNT STA TEMP2 AND TYPE WORDS. LDA IB130,I STA TEMP3 CCA SET CONTINUATION FLAG STA CFLAG JMP PHSR2 GO READ THE MAG TAPE... * * SKP * * * * * * UTILITY ROUTINES * * * PERFORMS .OP. E = 1/0 FOR TRUE/FALSE * .LE. NOP CMA,INA A<=B IF B-A IS (+) ADA B CLE,SSA,RSS CCE JMP .LE.,I * .GE. NOP CMB,INB A>=B IF A-B IS (+) ADA B CLE,SSA,RSS CCE JMP .GE.,I * * SKP * * TAPE NOP IOR MTLU,I = CONTROL CODE STA CONWD JSB EXEC DEF *+3 DEF THREE DEF CONWD JMP TAPE,I RETURN * * BCHK NOP JSB IFBRK CHECK BREAK FLAG DEF *+2 DEF * SSA,RSS IF SET, SET CODE = -4 JMP BCHK,I AND RETURN TO CALLER LDA DM4 JMP .BAD * * SKP * * * BUFFERS, CONSTANTS, AND STORAGE..... * * LNTAB DEF *+1 D37 DEC 37 * TABLE OF VALID MTLS D129 DEC 129 * RECORD LENGTHS DEC 129 * ONE DEC 1 * THREE DEC 3 * * FILE DEC 1 GETS MODIFIED... NMAX NOP INPUT TAPE-RECORD MAX ADDRESS PMAX NOP LOGICAL RECORD MAX ADDRESS EOTFL NOP END-OF-TAPE FLAG CFLAG NOP CONTINUATION FLAG NMOVE NOP * PRGTP NOP PROGRAM TYPE SS AA RR .99 ASC 1,99 SS ASC 1,SS RR ASC 1,RR AA ASC 1,AA DD ASC 1,DD RECTP NOP MTLS INFO RECORD TYPE LRLNT NOP LOGICAL RECORD LENGTH * BPNTR NOP DATA BUFFER POINTER DPNTR NOP DEST. BUFFER POINTER BBYTE NOP BUFFER BYTE SELECT MASK DBYTE NOP DEST. BUFR BYTE SELECT * * SKP * * CONSTANTS * * DM13 DEC -13 DM12 DEC -12 DM9 DEC -9 DM8 DEC -8 DM7 DEC -7 DM5 DEC -5 DM4 DEC -4 DM3 DEC -3 DM2 DEC -2 DM1 DEC -1 * TWO DEC 2 FOUR DEC 4 TWELV DEC 12 D13 DEC 13 D128 DEC 128 D131 DEC 131 D256 DEC 256 D1024 DEC 1024 D1025 DEC 1025 * B177 OCT 177 B200 OCT 200 B400 OCT 400 B1400 OCT 1400 B1300 OCT 1300 UPPER OCT 77400 SHIFT OCT 77577 HI.CR OCT 6400 LO.CR OCT 15 HI.LF OCT 5000 LO.LF OCT 12 DBLSP ASC 1, * .2DC3 OCT 11423 * * STORAGE * *q IB130 BSS 1 TLOG BSS 1 ISTAT BSS 1 CHKSM BSS 1 CHAR BSS 1 LFFLG BSS 1 TEMP1 BSS 1 TEMP2 BSS 1 TEMP3 BSS 1 END BSS 1 RECLN BSS 1 CONWD BSS 1 * *q A EQU 0 B EQU 1 * * END ASMB,R,B,L,C NAM ALPHA,7 REV A 750120 * DOES AN ALPHABETIC SORT ON 3-WORD FIELD IN (NAMES) IFILE FIELDS LONG. * IT ALSO SETS BIT 8 OF THE TRACK SECTOR WORD IF IT IS AN EXTENT. * CALLED FROM FTN BY: CALL ALPHA(NAMES,IFILE) ENT ALPHA EXT .ENTR NAMES BSS 1 IFILE BSS 1 ALPHA NOP JSB .ENTR DEF NAMES CLA STA RPEAT LDA IFILE,I CMA,INA STA CNTR1 LOOP1 EQU * LDA CNTR1 ADA IFILE,I ALS,ALS ADA NAMES STA ADDR1 STA PNTR1 LDA CNTR1 CPA RPEAT JMP OUT INA SZA,RSS JMP OUT STA CNTR2 LOOP2 EQU * LDA CNTR2 ADA IFILE,I ALS,ALS ADA NAMES STA ADDR2 STA PNTR2 LDA DM3 STA CNTR3 LDA ADDR1 LOOP3 EQU * LDB ADDR2,I CMB,INB ADB A,I INA ISZ ADDR2 SSB JMP END2 SZB JMP SWTCH ISZ CNTR3 JMP LOOP3 STA B LDA A,I IOR IFLAG SET A FLAG STA B,I IF A FILE LDA ADDR2,I EXTENT IOR IFLAG STA ADDR2,I JMP END2 SWTCH EQU * LDA DM4 STA CNTR4 LDA ADDR1 STA PNTR1 LOOP4 EQU * LDA PNTR1,I LDB PNTR2,I SWP STA PNTR1,I STB PNTR2,I ISZ PNTR1 ISZ PNTR2 ISZ CNTR4 JMP LOOP4 END2 EQU * ISZ CNTR2 JMP LOOP2 ISZ CNTR1 JMP LOOP1 OUT EQU * JMP ALPHA,I CNTR1 BSS 1 CNTR2 BSS 1 CNTR3 BSS 1 CNTR4 BSS 1 PNTR1 BSS 1 PNTR2 BSS 1 RPEAT BSS 1 ADDR1 BSS 1 ADDR2 BSS 1 IFLAG OCT 200 DM4 DEC -4 DM3 DEC -3 A EQU 0 B EQU 1 END