FTN4,L PROGRAM DXREF(3,74),24999-16246 REV.2024 800529 C C NAME: DXREF C SOURCE: 24999-18246 C RELOC: 24999-16246 C PGMR: G.J.S.,D.H.P C C MODIFIED TO SELECTIVELY SEARCH FOR EXT'S, ENT'S AND C CHECK FOR ARRAY OVERFLOW (300 MAX FOR BOTH). . .771117 C C MODIFIED TO OPTIONALLY DELETE ENTRY POINT LIST AND EXTERNAL C REFERANCES AND TO SELECTIVELY SEARCH MODULE NAMES. .760708 C C OFTEN IT IS NECESSARY TO KNOW THINGS ABOUT A PROGRAM SUCH C AS ENTRY POINTS, REQUIRED EXTERNAL REFERENCES, DEFAULT TYPE, C PRIORITY, OR COMMON BLOCK ALLOCATION, BUT THE SOURCE IS NOT C AVAILABLE. ALL THIS INFORMATION IS CONTAINED IN THE FIRST FEW C RECORDS OF THE RELOCATABLE FILE, BUT IS DIFFICULT TO DECIPHER C FROM A STRAIGHT OCTAL/ASCII DUMP. C C THE CAPABILITY TO RECOVER THIS INFORMATION IS OF PARTICULAR C IMPORTANCE IN BUILDING OR MODIFYING LIBRARIES AND IN PLANNING C GENERATOR COMMAND FILES. C C THUS WAS BORN "DXREF" WHICH IS SCHEDULED AS FOLLOWS: C C RU,DXREF[,NAMR][,LIST][,OPTIONS][,OPTIONS] C C WHERE: NAMR IS THE FILE NAME OR LU WHICH CONTAINS THE C RELOCATABLE TO BE 'XREFED'. C (OR) THE BATCH FILE NAME WHICH CONTAINS THE FILE C NAMES TO BE 'XREFED'.(DEFAULT: ASK USER) C C [LIST] OPTIONAL LIST OUTPUT LU.(DEFAULT: YOUR CRT) C C [OPTIONS] ANY COMBINATION OF THE FOLLOWING 2 LETTER C CODES. (ONLY 3 PER PARAMETER) C (DEFAULT: ASK USER) C C "LI" THIS WILL CAUSE DXREF TO ASK YOU FOR A C LIST OPTION WHICH WILL ALLOW YOU TO TURN C OFF LISTING OF ENTRY POINTS, EXTERNAL C REFERANCES, OR BOTH. C C "MO" THIS WILL CAUSE DXREF TO PROMPT YOU FOR A C 'FILTER' WHICH WILL ALLOW SELECTIVE LISTING C OF MODULES WITHIN A FILE. C C "EN" THIS WILL TELL DXREF TO ASK YOU FOR AN 'ENTRY POINT' C FILTER. THIS ALLOWS SEARCHING FOR AN ENTRY POINT. C C "EX" AND THIS TELLS DXREF TO ASK YOU FOR AN EXTERNAL REF. C FILTER. C C C "AL" THIS WILL TELL DXREF TO PROMPT YOU FOR ALL THE C FILTERS MENTIONED ABOVE. C C "BA" THIS WILL TELL DXREF TO USE THE GIVEN NAME IN THE C RUN STRING OR THE CURRENT FILE GIVEN AS THE BATCH C FILE TO BE USED AS THE INPUT FOR FILE NAMES C (SEE DESCRIPTION OF NAMR ABOVE). C C "RE" THIS INSTRUCTS DXREF TO CONTINUE ASKING FOR THE C FILTERS WHICH WHERE ASKED FOR INITIALLY. C C "SE" THIS TELLS DXREF TO ASK FOR ALL THE FILTERS C INITIALLY. C C "NO" (OR 'CR')EXIT OPTION SETTING PHASE. C C NOTE: ALL OPTIONS CAN BE CHANGED INTERACTIVELY. JUST TYPE C 'CO'(CHANGE OPTIONS) WHEN DXREF ASKS FOR FILE NAME AND C YOU WILL ENTER THE 'CHANGE OPTIONS MODE'. C (A '?' OR 'Y' WILL GIVE A LIST OF THE OPTIONS AND C THEIR CURRENT STATE. ADDITIONALLY YOU CAN 'TOGGLE' C THE CURRENT STATE BYE ENTERING THE CORRESPONDING C MNUMONIC.) C C THE 'SE' OPTION IS USEFUL WHEN SEARCHING FOR ONE PARTICULAR C MODULE, ENTRY POINT, OR EXTERNAL REFRENCE. ALL FILTERS AND C LIST OPTIONS ARE SET INITIALLY AND ARE NOT ASKED AGAIN. C THEREBY ALLOWING EASY SEARCHES OF MANY FILES FOR A SPECIFIC C PIECE OF INFORMATION. C C THE SAME FILE (OR BATCH FILE) CAN BE LOOKED AT AGAIN BY ENTERING C A SINGLE COLON(:) INSTEAD OF A FILE NAME. THIS ALLOWS SEARCHES C THROUGH ONE PARTICULAR FILE FOR MANY DIFFERINT PIECES OF INFORMATION. C A NOTE OF CAUTION HOWEVER: A DOUBLE COLON(::) WILL TERMINATE DXREF. C C*********************************************************************** C C OPTIONAL PARAMETERS HAVE SPECIAL MEANINGS IN DXREF. IF THE C SECURITY CODE IS SUPPLIED, AN EXCLUSIVE OPEN WILL BE ATTEMPTED, C OTHERWISE A NON-EXCLUSIVE OPEN WILL BE USED. IF THE CARTRIDGE C NUMBER IS NOT SPECIFIED, CARTRIDGES WILL BE SEARCHED IN THE ORDER C IN WHICH THEY APPEAR IN THE CARTRIDGE DIRECTORY AND THE FIRST C OCCURRENCE OF THE NAMED FILE WILL BE CROSS-REFERENCED. IF A C CARTRIDGE NUMBER IS GIVEN, ONLY THAT CARTRIDGE WILL BE SEARCHED. C DEFAULT THE FILE TYPE, AND DXREF WILL CHECK TO SEE IF THE FILE IS C TYPE 5, INDICATING A RELOCATABLE FILE. IF NOT, THE OPERATOR WILL C BE NOTIFIED AND ASKED IF HE WISHES TO CONTINUE. IF THE FILE TYPE C IS GIVEN IN THE NAMR PARAMETER, THE FILE WILL BE OPENED AS THAT C TYPE AND NO TYPE CHECK WILL BE MADE. C C FILE MANAGER ERRORS WILL BE REPORTED ON THE INTERACTIVE DEVICE C AND THE OPERATOR WILL BE AGAIN PROMPTED FOR THE LU#/FILE NAME. C THE OPERATION MAY BE TERMINATED AT THIS POINT BY ENTERING A DOUBLE C COLON FOR THE FILE NAME. ORDERLY TERMINATION AT ANY OTHER TIME C MAY BE ACCOMPLISHED BY SETTING THE PROGRAM'S BREAK FLAG. C C C C LOGICAL BATCH,FIRST,SPFILI,FILENM,ASKFIL,LMO,LEN,LEX,LLI, *FILOPN,FTIME,REPEAT,ONETIM,BANAME,ENTFL,EXTFL,FMOD,FENT,FEXT, *ENREC,EXREC C DIMENSION ILUST(128),IB(2),IFILT(6),NAM(64),IDCB(144), *LFNBUF(21) INTEGER TTY,SECURE,CARTDG,ERROR,OPTION,TYPE,OK,RTYPE, *FNAME(4),BLOCK(64),DCB(144),PBUF(10),ENTS(3,300), *EXTS(3,300),SUPFLG,OPFLG,BREG,AREG, *ENFLT(6),EXFLT(6),ENSKP,EXSKP,BLOCK4, *BLOCK2,BLOCK7,BLOCK8,BLOCK9,BLOC18,LEMA(3),EMASZ, *BLOCK6,PBUF4,PBUF5,PBUF6,PBUF7,BAFILE(4), *BASEC,BACART,BATYPE EQUIVALENCE (LENGTH,BREG),(ENTS,ILUST), *(BLOCK(4),BLOCK4),(IB(2),BREG),(IB(1),REG,AREG), *(BLOCK(2),BLOCK2),(BLOCK(7),BLOCK7),(BLOCK(8),BLOCK8), *(BLOCK(9),BLOCK9),(BLOCK(18),BLOC18),(BLOCK(6),BLOCK6), *(PBUF(4),PBUF4),(PBUF(5),BLOC5),(PBUF(6),PBUF6), *(PBUF(7),PBUF7) DATA ENFLT/0,2*2H::/,EXFLT/0,2*2H::/,ONETIM/.TRUE./ DATA BATCH/.FALSE./,FIRST/.TRUE./,SPFILI/.FALSE./ DATA ISTRC/1/,ASKFIL/.TRUE./,LLI/.FALSE./,LMO/.FALSE./, *LEN/.FALSE./,LEX/.FALSE./,FILENM/.FALSE./,FILOPN/.FALSE./, *FTIME/.FALSE./,REPEAT/.FALSE./,FNAME(4)/2H /, *BAFILE/2HNO,2H F,2HIL,2HE /,BANAME/.FALSE./,INITA/300/, *FMOD/.FALSE./,FENT/.FALSE./,FEXT/.FALSE./ C C STANDARD LU SETUP FOR INTERACTIVE AND LIST DEVICES. C TTY = LOGLU(LUTRUE) CALL GETST(DCB,-80,ILOG) ITTY = TTY + 400B LP = TTY ISKIP = 0 OPFLG = 0 LINES = 0 ASSIGN 90 TO JRTN ASSIGN 95 TO KRTN C C DECODE THE TURN ON STRING C DO 90 I=1,4 IF(NAMR(PBUF,DCB,ILOG,ISTRC))90,10 10 ITYPE = IAND(PBUF4,3) GO TO (20,50,60,60),I 20 IF(ITYPE .LE. 1)GO TO 40 FILENM = .TRUE. DO 30 J=1,3 FNAME(J) = PBUF(J) 30 CONTINUE SECURE = PBUF5 CARTDG = PBUF6 TYPE = PBUF7 GO TO JRTN 40 FNAME = PBUF FILENM = .FALSE. GO TO JRTN C C CHECK FOR LIST DEVICE C 50 IF(ITYPE .EQ. 1)LP = PBUF GO TO 90 C C CHECK FOR FILTERS C 60 IF(ITYPE .LE. 1)GO TO 90 LOOP = 3 70 DO 80 J=1,LOOP IF(PBUF(J) .EQ. 2HLO)LLI = .NOT. LLI IF(PBUF(J) .EQ. 2HMO)LMO = .NOT. LMO IF(PBUF(J) .EQ. 2HEN)LEN = .NOT. LEN IF(PBUF(J) .EQ. 2HEX)LEX = .NOT. LEX IF(PBUF(J) .EQ. 2HRE)REPEAT = .NOT. REPEAT IF(PBUF(J) .EQ. 2HSE)FTIME = .NOT. FTIME IF(PBUF(J) .EQ. 2HBA)BATCH = .NOT. BATCH IF(PBUF(J) .NE. 2HAL)GO TO 80 LLI = .TRUE. LMO = .TRUE. LEN = .TRUE. LEX = .TRUE. 80 CONTINUE IF(.NOT. LMO)IFILT = 0 IF(.NOT. LEN)ENFLT = 0 IF(.NOT. LEX)EXFLT = 0 OPFLG = 0 ASKFIL = .TRUE. IF(PBUF .EQ. 2HNO)ASKFIL = .FALSE. IF(LLI.OR.LMO.OR.LEN.OR.LEX.OR.FTIME)OPFLG = 1 IF(OPFLG .EQ. 1)ASKFIL = .FALSE. 90 CONTINUE C C SAVE BATCH FILE NAME IN ITS PROPER PLACE C IF(BATCH .AND. FILENM)GO TO 132 C C CHECK IF WE ASK FOR FILTERS ? C 95 IF(.NOT.ASKFIL)GO TO 115 C 100 WRITE(TTY,110) 110 FORMAT(" FILTER OPTIONS ? _") REG = REIO(1,ITTY,PBUF,10) IF(BREG .EQ. 0)GO TO 115 IF(PBUF .NE. 2HLL .AND. PBUF .NE. 2HLI)GO TO 112 CALL CODE(BREG*2) READ(PBUF,*)LP,LP 112 LOOP = BREG LCHK = IOR(IAND(PBUF,77400B),40B) IF(LCHK .NE. 1H? .AND. LCHK .NE. 1HY)GO TO 70 114 ASSIGN 95 TO KRTN WRITE(TTY,120)LP,LLI,LMO,LEN,LEX,REPEAT,FTIME,BATCH,BAFILE 120 FORMAT(/" ENTER ANY SEQUENCE OF THE FOLLOWING 2 LETTER CODES"/ #6X"STATE"/ #" LIST = "I3/ #" LO - ("L1") ASK FOR LISTING OPTIONS"/ #" MO - ("L1") ASK FOR FILTERING BY MODULE NAME"/ #" EN - ("L1") ASK FOR FILTERING BY ENTRY POINT NAME"/ #" EX - ("L1") ASK FOR FILTERING BY EXTERNAL REFERANCE"/ #" RE - ("L1") REPEAT FILTER QUESTIONS AS SET ABOVE"/ #" SE - ("L1") SET ALL FILTERS INITIALLY ONLY"/ #" BA - ("L1") "4A2"WILL BE USED AS BATCH FILE"/ #" AL - ASK FOR ALL FILTERS"/ #" NO - (OR 'CR') LEAVE FILTER OPTIONS AS IS"// #" NOTE: ANY CODE ENTERED WILL TOGGLE CURRENT STATE"/) GO TO 100 C C CHECK FOR DEFAULT, LU, OR FILE NAME. C 115 NAMCNT = 0 IF(BATCH .AND. BANAME)GO TO 142 IF (FNAME .LE. 0) GO TO 202 IF (FNAME .LE. 255) GO TO 220 IF (FILENM)GO TO 220 GO TO 202 C C COPY BATCH DCB TO NEW ONE AND READ BATCH FILE C 125 DO 130 J=1,16 IDCB(J) = DCB(J) 130 CONTINUE ASSIGN 137 TO KRTN C C SAVE BATCH FILE NAMR C 132 DO 135 J=1,4 BAFILE(J) = FNAME(J) 135 CONTINUE BASEC = SECURE BACART= CARTDG BATYPE= TYPE BANAME= .TRUE. GO TO KRTN C C RESTORE BATCH FILE NAME TO FNAME C 142 DO 145 J=1,4 FNAME(J) = BAFILE(J) 145 CONTINUE SECURE = BASEC CARTDG = BACART TYPE = BATYPE FIRST = .TRUE. GO TO 220 C C 137 SPFILI = .FALSE. BATCH = .TRUE. FIRST = .TRUE. FILOPN = .FALSE. CALL RWNDF(IDCB,IERR) OK = 0 WRITE(TTY,140) 140 FORMAT("/DXREF: SUPPRESS FILE NAME REPORTING ? _") READ(TTY,410)OK IF(OK .EQ. 1HY)SPFILI = .TRUE. C C READ NEXT RECORD FROM BATCH FILE C 150 CALL READF(IDCB,IERR,BLOCK,15,LENGTH) IF(IERR .LT. 0)GO TO 160 BREG = LENGTH * 2 C C GET OUT IF EOF FOUND C IF(LENGTH .LT. 0)GO TO 175 IF(.NOT.FIRST)CALL CLOSE(DCB) FIRST = .FALSE. OPFLG = 0 GO TO 215 C C PROCESS READF ERROR C 160 WRITE(TTY,170)IERR 170 FORMAT("/DXREF: READF ERROR "I3" IN BATCH FILE") C C EOF OR READ PROBLEM IN BATCH FILE C 175 BATCH = .FALSE. CALL CLOSE(IDCB) GO TO 185 C C COME HERE ON 'BREAK' C 180 FMOD = .FALSE. IFTIME = 0 IF(REPEAT)OPFLG = 1 IF(.NOT. BATCH)GO TO 200 185 CALL CLOSE(DCB) FILOPN = .FALSE. GO TO 202 C C ASK OPERATOR FOR INPUT LU/FILE NAME AND PARSE. C 200 IF(BATCH)GO TO 150 202 IF(ONETIM)WRITE(TTY,205) 205 FORMAT("/DXREF: ('CO' => CHANGE OPTIONS: '::' TO STOP)") ONETIM = .FALSE. WRITE (TTY,210) 210 FORMAT ("/DXREF: ENTER INPUT FILE NAME (LU): _") REG=REIO (1,ITTY,BLOCK,-20) IF(BREG.EQ.1.AND.BLOCK.EQ.1H:.AND.FILOPN)GO TO 220 IF(BREG.EQ.1.AND.BLOCK.EQ.1H:.AND.BATCH)GO TO 137 IF(BREG.NE.1. OR.BLOCK.NE.1H:)GO TO 206 WRITE(TTY,203) 203 FORMAT(" NO FILE CURRENTLY OPEN") GO TO 202 206 FILENM = .FALSE. BATCH = .FALSE. IF(BREG.EQ.2.AND.BLOCK.EQ.2HCO)GO TO 114 C C CHECK FOR TERMINATE REQUEST C IF (BLOCK .EQ. 2H::) GO TO 850 IF (BLOCK .EQ. 2H/E .AND. BREG .EQ. 2) GO TO 850 IF (BREG .EQ. 0) GO TO 850 CALL CLOSE(DCB) 215 FILOPN = .FALSE. ISTRC = 1 CALL NAMR(PBUF,BLOCK,BREG,ISTRC) ASSIGN 220 TO JRTN ITYPE = IAND(PBUF4,3) GO TO 20 220 IF(FNAME .EQ. 0)GO TO 850 IF(FILOPN)CALL RWNDF(DCB) IF(OPFLG.EQ.1)GO TO 240 GO TO 370 C C ASK FOR LIST OPTION AND SPECIAL SEARCH OPTIONS C 240 OPFLG = 0 IF(REPEAT)OPFLG = 1 IF(FTIME)GO TO 250 IF(.NOT. LLI)GO TO 280 250 WRITE(TTY,260) 260 FORMAT("/DXREF: LIST OPTION : ENT, EXT, BOTH, OR NONE _") READ(TTY,270)SUPFLG 270 FORMAT(A2) IF(FTIME)GO TO 290 280 IF(.NOT. LMO)GO TG 310 290 WRITE(TTY,300) 300 FORMAT("/DXREF: ENTER MODULE NAME FILTER" #6X"( - = DON'T CARE): _") CALL FILTR(TTY,IFILT,LIFILT) IF(FTIME)GO TO 320 310 IF(.NOT. LEN)GO TO 340 320 WRITE(TTY,330) 330 FORMAT("/DXREF: ENTER ENTRY POINT NAME FILTER" *" ( - = DON'T CARE): _") CALL FILTR(TTY,ENFLT,LENFLT) IF(FTIME)GO TO 350 340 IF(.NOT. LEX)GO TO 370 350 WRITE(TTY,360) 360 FORMAT("/DXREF: ENTER EXTERNAL NAME FILTER" *4X"( - = DON'T CARE): _") CALL FILTR(TTY,EXFLT,LEXFLT) C C OPEN THE FILE AND CHECK ITS TYPE & CARTRIDGE. C 370 FTIME = .FALSE. IF(FNAME.LE.255)GO TO 480 C C IF SEC. CODE GIVEN, OPEN EXCLUSIVELY C OPTION = 1 IF (SECURE .NE. 0) OPTION = 0 IF(FILOPN)GO TO 450 CALL OPEN (DCB,ERROR,FNAME,OPTION,SECURE,CARTDG) IF (ERROR .LT. 0) GO TO 430 FILOPN = .TRUE. IF(CARTDG.GT.0)GO TO 390 CALL LOCF(DCB,IDUM,IDUM,IDUM,IDUM,IDUM,JLU) CALL FSTAT(ILUST) DO 380 JK=1,31 JJ = (JK-1)*4 + 1 IF(JLU.NE.ILUST(JJ))GO TO 380 CARTDG = ILUST (JJ + 2) GO TO 390 380 CONTINUE C C FILE IS NOW OPEN. CHECK IF IN BATCH C 390 IF(BATCH .AND. FIRST)GO TO 125 IF(ERROR.EQ.TYPE.OR.ERROR.EQ.5)GO TO 450 C C IGNORE FILE IF NOT TYPE 5 OR NOT EXPLICITLY STATED (BATCH) C IF(.NOT.BATCH) GO TO 395 ASSIGN 200 TO IRTN LTYPE = ERROR WRITE(TTY,392) 392 FORMAT("FILE NOT PROCESSED") GO TO 460 C C IF NOT IN BATCH AND FILE TYPE NOT 5 OR SUPPLIED C ASK IF WE CAN USE AS BATCH FILE. C 395 WRITE(TTY,400) FNAME,ERROR 400 FORMAT("/DXREF: FILE ",4A2," IS TYPE ",I5,". OK TO USE AS" #" BATCH FILE ? _") READ (TTY,410) OK 410 FORMAT(A1) IF(OK.EQ.1HY)GO TO 125 C C IF NOT BATCH FILE, HOW ABOUT 'DXREFING' IT. C WRITE(TTY,420) 420 FORMAT("/DXREF: OK TO PROCESS THEN ? _") READ (TTY,410) OK IF(OK.EQ.1HY)GO TO 450 GO TO 200 430 WRITE (TTY,440) ERROR,FNAME 440 FORMAT (" FMGR ERROR ",I4," OPENING ",4A2,".") GO TO 200 450 NAMCNT = 0 INITA = 300 LTYPE = ERROR ASSIGN 480 TO IRTN C C CHECK IF WE'RE SUPPRESSING FILE NAME REPORTING C IF(SPFILI)GO TO 480 460 CALL CODE WRITE (LFNBUF,470) FNAME,SECURE,CARTDG,LTYPE IACRT = -1 CALL ASCII(CARTDG,IACRT) IF(IACRT .EQ. 2H )GO TO 465 LFNBUF(16) = 2H: LFNBUF(17) = 2H LFNBUF(18) = IACRT 465 IF (TTY .EQ. LP)GO TO 468 IF(LINES .GT. 1)CALL EXEC(3,LP+1100B,-1) CALL EXEC(2, LP,LFNBUF,21) 468 CALL EXEC(2,TTY,LFNBUF,21) 470 FORMAT (" * FILE NAME: ",4A2,":",I5,":",I5,":",I5) LINES = 1 GO TO IRTN C C GET AN INPUT RECORD. C 480 IF (IFBRK(IDUMMY) .NE. 0) GO TO 180 IF (FNAME .LE. 255) GO TO 490 CALL READF (DCB,ERROR,BLOCK,64,LENGTH) IF(ERROR .GE. 0)GO TO 500 WRITE(TTY,485)ERROR,FNAME 485 FORMAT("/DXREF: READF ERROR "I3" IN "4A2) GO TO 200 490 REG=EXEC (1,300B+FNAME,BLOCK,64) C C CHECK FOR EOF C ICHK = IAND(240B,AREG) IF(ICHK.NE.0)GO TO 200 500 IF (LENGTH .NE. -1) GO TO 510 IFTIME = 0 GO TO 200 C C SKIP ZERO(0) LENGTH RECORD C 510 IF (LENGTH .EQ. 0) GO TO 480 C C CHECK FOR "DBL" (DATA BLOCK) RECORD. C RTYPE=IAND (BLOCK2,160000B) IF (RTYPE .EQ. 60000B) GO TO 480 C C CHECK FOR "NAM" RECORD. C IF(RTYPE.NE.20000B.AND.ISKIP.EQ.0)GO TO 480 IF (RTYPE .NE. 20000B) GO TO 560 NAMCNT=NAMCNT+1 ENTFL = .FALSE. EXTFL = .FALSE. ISKIP = -1 C C FILTER MODULES FOR SELECTIVE LISTING C IF(IFILT .EQ. 0)GO TO 520 CALL NAMCK(BLOCK4,5,IFILT,LIFILT,ISKIP) IF(ISKIP.EQ.0)GO TO 480 520 BLOCK=(BLOCK/256) C C SAVE NAME INFO FOR LATER PRINT OUT C DO 530 I=1,BLOCK NAM(I) = BLOCK(I) 530 CONTINUE FMOD = .TRUE. FENT = .TRUE. FEXT = .TRUE. ENREC= .FALSE. EXREC= .FALSE. IF (NAM .LT. 18)NAM(18) = 20040B LNPROG=BLOCK7 NBPALL=BLOCK8 NCMMON=BLOCK9 LSTENT=1 LSTEXT=1 DO 550 I=1,INITA DO 540 J=1,3 ENTS(J,I)=20040B EXTS(J,I)=20040B 540 CONTINUE 550 CONTINUE GO TO 480 C C CHECK FOR "ENT" RECORD. C 560 IF (RTYPE .NE. 40000B) GO TO 600 IF(ENTFL)GO TO 480 IF(.NOT.ENREC) FENT = .FALSE. ENREC = .TRUE. NUMBER=IAND(BLOCK2,17B) DO 590 I=1,NUMBER ISUBSC=4*I IF(ENFLT .EQ. 0)GO TO 570 CALL NAMCK(BLOCK(ISUBSC),5,ENFLT,LENFLT,ENSKP) IF(ENSKP .EQ. 0)GO TO 590 570 IF(SUPFLG.EQ.2HEX.OR.SUPFLG.EQ.2HNO)GO TO 585 DO 580 J=1,3 ENTS(J,LSTENT)=BLOCK(J-1+ISUBSC) IF (J .EQ. 3) ENTS(J,LSTENT)=IOR(IAND(ENTS(J,LSTENT),177400B),40B) 580 CONTINUE LSTENT=LSTENT+1 FENT = .TRUE. C C CHECK FOR ARRAY OVERFLOW C IF(LSTENT .LT. 300)GO TO 590 ENTFL = .TRUE. GO TO 830 585 FENT = .TRUE. 590 CONTINUE GO TO 480 C C CHECK FOR "EXT" RECORD. C 600 IF (RTYPE .NE. 100000B) GO TO 640 IF(EXTFL)GO TO 480 IF(.NOT.EXREC) FEXT = .FALSE. EXREC = .TRUE. NUMBER=IAND(BLOCK2,37B) DO 630 I=1,NUMBER ISUBSC=4+3*(I-1) IF(EXFLT .EQ. 0)GO TO 610 CALL NAMCK(BLOCK(ISUBSC),5,EXFLT,LEXFLT,EXSKP) IF(EXSKP .EQ. 0)GO TO 630 610 IF (SUPFLG.EQ.2HEN.OR.SUPFLG.EQ.2HNO)GO TO 625 DO 620 J=1,3 EXTS(J,LSTEXT)=BLOCK(J-1+ISUBSC) IF (J .EQ. 3) EXTS(J,LSTEXT)=IOR(IAND(EXTS(J,LSTEXT),177400B),40B) 620 CONTINUE LSTEXT=LSTEXT+1 FEXT = .TRUE. C C CHECK FOR ARRAY OVERFLOW C IF(LSTEXT .LT. 300)GO TO 630 EXTFL = .TRUE. GO TO 830 625 FEXT = .TRUE. 630 CONTINUE GO TO 480 C C CHECK FOR "EMA" RECORD. C 640 IF (RTYPE .NE. 140000B) GO TO 645 BLOCK6 = IOR(40B,IAND(BLOCK6,77400B)) DO 642 I=1,3 LEMA(I) = BLOCK(I+3) 642 CONTINUE MSEGSZ = IAND(BLOCK7,13B) EMASZ = IAND(BLOCK2,17777B) GO TO 480 C C CHECK FOR "END" RECORD. C 645 IF (RTYPE .NE. 120000B) GO TO 810 LSTENT=LSTENT-1 LSTEXT=LSTEXT-1 CALL ALPHD(ENTS,LSTENT) CALL ALPHD(EXTS,LSTEXT) NLINES=4 IF (LSTENT .GT. NLINES) NLINES=LSTENT IF (LSTEXT .GT. NLINES) NLINES=LSTEXT C C CHECK TO SEE IF WE SKIP PRINTOUT C C SET THE 'PRINT OUT FLAG' FALSE FOR THE FOLLOWING CONDITIONS C C 1. IF NO RECORD OF THAT TYPE FOUND C AND C 2. A FILTER WAS SPECIFIED => FLAG = .FALSE. C IF(.NOT.ENREC .AND. ENFLT .NE. 0)FENT = .FALSE. IF(.NOT.EXREC .AND. EXFLT .NE. 0)FEXT = .FALSE. IF(FMOD .AND. FENT .AND. FEXT)GO TO 650 GO TO 480 650 IF(IFTIME .GT. 0)GO TO 680 IFTIME = 1 IF(.NOT.SPFILI)GO TO 660 ASSIGN 660 TO IRTN GO TO 460 660 WRITE(LP,670) 670 FORMAT(/3X,"MODULE",37X,"ENTRY PTS",5X,"EXTERNALS"/, *3X,"------",37X,"---------",5X,"---------" ) 680 WRITE (LP,690) NAMCNT,(NAM(I),I=4,6),(NAM(J),J=10,17), *(NAM(K),K=18,NAM) 690 FORMAT (1X,I3,2X,3A2,",",I3,",",I5,",",I1,",",I4,4(",",I2), *2(/12X,30A2)) LINES = LINES + 6 IF(NAM .GT. 48)LINES = LINES + 1 DO 770 I=1,NLINES L = 2H * IF (LSTEXT .LT. I .AND. LSTENT .LT. I)L=20040B IF (IFBRK(IDUMMY) .NE. 0) GO TO 180 IF (LNPROG .EQ. 0) GO TO 710 WRITE (LP,700)LNPROG,L,(ENTS(J,I),J=1,3),L,(EXTS(K,I),K=1,3),L 700 FORMAT (11X"PROGRAM LENGTH (IN WORDS)=",I5,A2,4X,3A2,2X,A2,4X, #3A2,2X,A2) LNPROG=0 LINES = LINES + 1 GO TO 770 710 IF (NCMMON .EQ. 0) GO TO 730 WRITE (LP,720)NCMMON,L,(ENTS(J,I),J=1,3),L,(EXTS(K,I),K=1,3),L 720 FORMAT (21X,"WORDS IN COMMON="I5,A2,4X,3A2,2X,A2,4X,3A2,2X,A2) NCMMON=0 LINES = LINES + 1 GO TO 770 730 IF (NBPALL .EQ. 0) GO TG 745 WRITE (LP,740)NBPALL,L,(ENTS(J,I),J=1,3),L,(EXTS(K,I),K=1,3),L 740 FORMAT(16X"BASE PAGE ALLOCATION="I5,A2,4X,3A2,2X,A2,4X,3A2,2X,A2) NBPALL=0 LINES = LINES + 1 GO TO 770 745 IF (EMASZ .EQ. 0) GO TO 750 WRITE(LP,748)LEMA,MSEGSZ,EMASZ,L,(ENTS(J,I),J=1,3),L, $(EXTS(K,I),K=1,3),L 748 FORMAT(5X"EMA BLOCK "3A2"(MSEG="I2")="I5" PAGES"A2,4X,3A2,2X,A2, $4X,3A2,2X,A2) EMASZ=0 LINES = LINES + 1 GO TO 770 750 IF (LSTEXT .LT. I .AND. LSTENT .LT. I)GO TO 770 WRITE (LP,760) ((ENTS(J,I),J=1,3),(EXTS(K,I),K=1,3)) LINES = LINES + 1 760 FORMAT (43X,"*",4X,3A2,3X,"*",4X,3A2,3X,"*") 770 CONTINUE C C SET INITIALIZE COUNTER TO ONLY WHAT WAS USED C INITA = NLINES C C AND RESET 'FOUND' FLAGS C FMOD = .FALSE. LINES = LINES + 2 IF(LSTENT.EQ.0.AND.LSTEXT.EQ.0)GO TO 790 WRITE (LP,780) 780 FORMAT (13X,30("* "),/) GO TO 480 790 WRITE(LP,800) 800 FORMAT(/) GO TO 480 C C UNDEFINED RECORD TYPE INDICATED HERE. C 810 WRITE (LP,820) BLOCK2 820 FORMAT (" RECORD TYPE ",K6," NOT PROCESSED.") GO TO 480 830 WRITE(TTY,840)ENTFL,EXTFL GO TO 480 840 FORMAT(" ENT("L1") OR EXT("L1") ARRAY OVERFLOW (300 MAX)") C C ORDERLY DEPARTURE. C 850 CALL CLOSE (DCB) IF(BATCH)CALL CLOSE (IDCB) IF(LINES .GT. 0 .AND. LP .NE. TTY)CALL EXEC(3,LP+1100B,-1) WRITE (TTY,860 ) 860 FORMAT ("$END DXREF.") END SUBROUTINE FILTR(TTY,IFILT,LEN) +,24999-16246 REV.2024 791009 DIMENSION IB(2),IFILT(6) INTEGER TTY,BREG,AREG EQUIVALENCE (IB(2),BREG),(IB(1),REG,AREG) C C INITIALIZE IFILT C DO 100 I=1,6 IFILT(I) = 2H-- 100 CONTINUE C REG = REIO(1,TTY+400B,IFILT,-12) LEN = BREG IODD = (BREG/2)+1 IF(MOD(BREG,2).NE.0)IFILT(IODD)=IOR(IFILT(IODD),55B) C DO 110 I=1,IODD IF(IFILT(I) .NE. 2H--)RETURN 110 CONTINUE IFILT = 0 RETURN END SUBROUTINE ASCII(BINARY,IA) +, REV.1929 790720 C C THIS ROUTINE PERFORMS TWO(2) FUNCTIONS: C C 1. CHECK THE CONTENTS OF A WORD TO ENSURE BOTH BYTES C ARE UPPER CASE PRINTING ASCII, IF EITHER BYTE FAILS C TWO ASCII BLANKS (20040B) WILL BE SENT BACK TO THE C CALLER. THIS MODE IS INVOKED BY SETTING THE SECOND C PARAMETER TO -1 WHEN CALLED. C C 2. GIVEN A BINARY VALUE. CHECK FOR UPPER AND LOWER CASE C PRINTING ASCII, IF NOT, SET THE OFFENDING BYTE TO AN C ASCII BLANK. C INTEGER BINARY,RBYTE RBYTE = IAND(BINARY,377B) LBYTE = IAND(BINARY,77400B) IF(IA .NE. -1)GO TO 10 IF(RBYTE .LT. 40B .OR. RBYTE .GT. 137B)GO TO 5 IF(LBYTE .LE. 20000B .OR. LBYTE .GE. 60000B)GO TO 5 IA = BINARY RETURN 5 IA = 20040B RETURN 10 IF(RBYTE.LT.40B.OR.RBYTE.GT.176B)RBYTE = 40B IF(LBYTE.LT.20000B)LBYTE = 20000B IF(LBYTE.GE. 77400B)LBYTE = 20000B IA = IOR(LBYTE,RBYTE) RETURN END END$ ASMB,R,B,L,C NAM ALPHD,7 REV.1939 790928 * DOES AN ALPHABETIC SORT ON 3-WORD FIELD IN (NAMES) IFILE FIELDS LONG. * (A BUBBLE SORT METHOD IS USED.) * CALLED FROM FTN BY: CALL ALPHA(NAMES,IFILE) ENT ALPHD EXT .ENTR NAMES BSS 1 IFILE BSS 1 ALPHD NOP JSB .ENTR ESTABLISH ADDRESSES DEF NAMES LDA IFILE,I SET -NUMBER OF NAMES CMA,INA AS COUNTER STA CNTR1 * * LOOP1 SETS ADDRESSES AND POINTERS FOR FIRST FIELD * CHECKS FOR END OF SORT * LOOP1 EQU * LDA CNTR1 SET NEW INDEX ADA IFILE,I INTO NAME ARRAY MPY D3 (3 WORDS/NAME) ADA NAMES STA ADDR1 SAVE THE ADDRESS STA PNTR1 AND AS A POINTER LDA CNTR1 CPA D0 CHECK FOR NONE LEFT JMP OUT OR ZERO INITIALLY INA SZA,RSS JMP OUT DONE !!! STA CNTR2 CNTR2=CNTR1 + 1 * * LOOP2 SETS ADDRESSES AND POINTERS FOR SECOND FEILD * LOOP2 EQU * LDA CNTR2 COMPUTE ADDRESS OF ADA IFILE,I SECOND FIELD MPY D3 ADA NAMES STA ADDR2 STA PNTR2 LDA DM3 SET UP COUNTER FOR FIELD STA CNTR3 COMPARISION LDA ADDR1 LOOP3 EQU * START THE COMPARISION LDB ADDR2,I CMB,INB NAME1 - NAME2 < 0 ? ADB A,I INA NEXT WORD OF NAME1 ISZ ADDR2 NEXT WORD OF NAME2 SSB NAME1 < NAME2 ? JMP END2 PROPER ORDER SZB SAME ? JMP SWTCH NO, SWITCH IT. ISZ CNTR3 IF FIRST WORDS = JMP LOOP3 CONTINUE LOOP JMP END2 ALL FIELDS ARE =. SWTCH EQU * LDA DM3 SET UP FOR 3 WORD STA CNTR4 SWITCH LDA ADDR1 1ST NAME STA PNTR1 SAVE FOR LOOP LOOP4 EQU * LDA PNTR1,I START SWAP LOOP LDB PNTR2,I SWP STA PNTR1,I STB PNTR2,I ISZ PNTR1 BUMP ADDRESS FOR NAME1 ISZ PNTR2 BUMP ADDRESS FOR NAME2 ISZ CNTR4 DONE? JMP LOOP4 NO END2 EQU * YES ISZ CNTR2 DONE WITH LOOP2 JMP LOOP2 NOPE. ISZ CNTR1 ALL DONE JMP LOOP1 OUT EQU * YES, GET OUT JMP ALPHD,I CNTR1 BSS 1 CNTR2 BSS 1 CNTR3 BSS 1 CNTR4 BSS 1 PNTR1 BSS 1 PNTR2 BSS 1 ADDR1 BSS 1 ADDR2 BSS 1 D0 DEC 0 DM3 DEC -3 D3 DEC 3 A EQU 0 END ASMB,R,B,L,C NAM COMMA,7 REV A 751031 * * FRI 31 OCT 75 WRITTEN BY DONALD H. POTTENGER REV A * ENT COMMA EXT .ENTR * THIS SUBROUTINE, GIVEN AN ADDRESS AND LENGTH OF A BUFFER, * WILL CHECK FOR IMBEDDED COLONS AND REPLACE THEM WITH COMMAS * FOR THE SYSTEM PARSE ROUTINE. THIS HAS OBVIOUS ADVANTAGES * FOR THE USER WHO IS USED TO USING COLONS AS DELIMITERS AS IN * THE FILE MANAGER NAMR PARAMATERS. * * THE BUFFER CAN BE ANY LENGTH AND SHOULD SPECIFY * THE NUMBER OF CHARACTERS IN THE BUFFER. * BUFAD NOP BUFFER ADDRESS BUFLA NOP BUFFER LENGTH COMMA NOP WHERE IT ALL BEGINS JSB .ENTR GO GET THE ADDRESSES DEF BUFAD OF THE PARAMATERS LDA BUFLA,I HOW ABOUT THE LENGTH? CLE,ERA IS IT AN ODD CHARACTER COUNT? SEZ NO, ITS ALL READY TO GO INA YES, INCREASE THE WORD COUNT BY ONE CMA,INA LET'S MAKE IT NEG. FOR COUNTING STA BUFL AND SAVE IT SZA,RSS IS IT A ZERO LENGTH BUFFER? JMP COMMA,I WELL GET THE HECK OUT OF HERE THEN. START LDA BUFAD,I ORIGINAL NAME HUH ? STA TEMP LET'S GET A WORD AND GET ON WITH IT AND M177 HOW ABOUT THE LOW BYTE? CPA LOCOL A COLON? JMP LFIX YES, GO MAKE IT A COMMA PAR1 LDA TEMP NO, PREPARE TO CONTINUE AND M774 THIS TIME LOOK AT THE HI BYTE CPA HICOL A COLON? JMP HFIX YES, GO MAKE IT A COMMA JMP TERM1 NO, LETS SAVE WHAT WE HAVE AND GO ON LFIX LDA TEMP GET ORIGINAL WORD ADA M16 MAKE THAT COLON A COMMA STA TEMP AND SAVE JMP PAR1+1 GO CHECK HI BYTE HFIX LDA TEMP GET PRESENT VALUE ADA M7000 MAKE THE HI BYTE COLON A COMMA RSS AND SAVE IN ORIGINAL BUFFER TERM1 LDA TEMP LETS GET THE CURRENT VALUE STA BUFAD,I AND SAVE IN ORIGINAL BUFFER ISZ BUFAD INCREMENT THE BUFFER ADDRESS ISZ BUFL ANY MORE WORDS? JMP START YES, HERE WE GO AGIAN JMP COMMA,I NOPE, LETS GET OUT!! SKP * * CONSTANTS AND STORAGE * BUFL NOP TEMP NOP M177 OCT 177 M774 OCT 77400 LOCOL OCT 72 HICOL OCT 35000 M16 OCT -16 M7000 OCT -7000 END ASMB,R,L * 1730 HRS THU 14 JUN 79 NAM NAMCK,7 REV. 1924 790614 CHECK FILE NAME ENT NAMCK EXT .ENTR * * THIS SUBROUTINE RETURNS A FLAG (0,-1) TO DL DEPENDING * ON HOW A GIVEN STRING(KNOWN AS THE FILTER) COMPARES TO ANOTHER * STRING(KNOWN AS THE FILE NAME). * * CALLING SEQUENCE: * * CALL NAMCK(IBUF,ICHAR,JBUF,JCHAR,IFLAG) * * WHERE: * IBUF = THE FILE NAME TO BE CHECKED * ICHAR= NO. OF CHARACTERS IN IBUF * JBUF = SMALLER BUFFER CONTAINING SEARCH FILTER * JCHAR= NO. OF CHARCTERS IN JBUF * IFLAG= -1 IF STRING FOUND; 0 IF NOT FOUND * * VARIABLE DEFINITION: * * BADDR = BYTE ADDRES FOR INPUT BUFFER * SADDR = BYTE ADDRES FOR INPUT FILTER BUFFER * ICNT = -(NUMBER CHARACTERS IN SOURCE BUFFER) * JCNT = -(NUMBER CHARACTERS LEFT IN SEARCH FILTER) * STGCT = CHAR. COUNT IN CURRENT STRING CHECK BUFFER * Y-REG = CHECK STRING BUFFER ADDRESS * * IBUF NOP FILE NAME BUFFER ICHAR NOP NO. OF CHAR. IN IBUF JBUF NOP FILTER STRING JCHAR NOP NO. OF CHAR. IN JBUF IFLAG NOP IFLAG SET TO -1 IF STRING FOUND NAMCK NOP ENTRY POINT JSB .ENTR DEF IBUF CLA CLEAR STA STGCT CURRENT STRING COUNTER STA PLSFG RESET PLUS FLAG CCA SET OUTER CMPAR LOOP STA OUTLG TO ONE TIME LDA ICHAR,I GET FILE NAME BUFFER LGTH. CMA,INA SET NEG. STA ICNT AND SAVE LOCAL LDA JCHAR,I GET THE FILTER LENGTH CMA MAKE NEGITIVE STA JCNT SAVE COUNTER (-1) LDA IBUF RAL STA BADDR SAVE AS BYTE ADDRESS LDB JBUF RBL STB SADDR SAVE THE BYTE ADD. FOR FILTER NXBT ISZ JCNT CHECK FOR END OF FILTER BUFFER RSS JMP DONE DONE THEN LBT GET THE NEXT FILTER CHAR. CPA APLUS CHECK FOR PLUS JMP PLUS CPA AMINS CHECK FOR '-'S JMP MINUS LDA STGCT CHECK FOR BEGINNING SZA OF A STRING JMP NX.1 LDY SADDR YES, SO SAVE FILTER BUFFR ADD. IN Y LDX BADDR AND THE SOURCE BUFFR ADD. IN X NX.1 ISZ STGCT BUMP STRING COUNTER ADA ICNT CHECK FOR POSSIBLE STRING CHECK SSA,RSS OVER RUN JMP DONE IF ABOUT TO OVER RUN-GO CHECK JMP NXBT GO GET NEXT BYTE SPC 2 * MINUS ISZ BADDR BUMP SOURCE STRING BUFFER POINTER LDA STGCT CHECK IF STRING CHECK PENDING SZA JMP MIN.1 YES, SO GO DO IT ISZ SADDR BUMP FILTER BUFFER ADD TOO. ISZ ICNT ANY CHARATERS LEFT ? JMP NXBT YES, SO GET NECT BYTE JMP EXFND NO, SO EXIT FOUND SPC 1 MIN.1 STB SADDR SAVE THE FILTER BUFFER POINTER LDA PLSFG CHECK FOR "+" FLAG SZA,RSS SET ? JMP MIN.2 YES LDA ICNT FORM OUTER LOOP COUNTER ADA STGCT OUTLG = ICNT + STGCT SSA,RSS SEE IF LEGAL LOOP COUNTER JMP EXNFD NO, SEE EXIT NOT FOUND STA OUTLG OK, SAVE MIN.2 JSB CHECK GO CHECK STRING INA BUMP SOURCE BUFFER STA BADDR ADDRESS LDB SADDR CLA RESET THE '"+"' STA PLSFG FLAG CMA AND THE OUTER STA OUTLG LOOP COUNTER LDA ICNT INA JMP NXT GO CLEAN UP SPC 1 PLUS STB SADDR SAVE FILTER BUFFER POINTER LDA STGCT SEE IF CURRENT STRING SZA TO PROCESS JMP PL.1 YES STB PLSFG NO, SET '"+"' HAS OCCURED FLAG JMP NXBT NO, SO JUST GET NEXT BYTE PL.1 LDA PLSFG CHECK FOR '"+"' FLAG SZA,RSS JMP PL.2 FLAG NOT SET SO SET TO ONE TIME * LDA ICNT SET OUTER LOOP COUNTER ADA STGCT TO CHECK ALL OF BUFFER ADA M1 SSA,RSS CHECK IF 1 CMPAR WILL DO. PL.2 CCA YES, SO SET OUTER LOOP TO -1 STA OUTLG SAVE OUTER LOOP COUNTER JSB CHECK STA PLSFG SET '"+"' FLAG NON ZERO JMP CONT * * CHECK STRING * CHECK NOP ENTER CHECK ROUTINE HERE AGAIN CXA GET SOURCE BUFFER ADD. FROM X-REG. CYB GET FILTER ADD. FROM Y-REG. CBT STGCT CMPAR STRING JMP CHECK,I RETURN TO CALLER NOP ISZ OUTLG SEE IF WE ARE DONE RSS NO, JMP EXNFD YES, GO SET NOT FOUND FLAG * ISX BUMP SOURCE BUFFER ADDRESS ISZ ICNT AND SOURCE CHAR. COUNT JMP AGAIN AND GO AGAIN * EXNFD CLA STA IFLAG,I JMP NAMCK,I AND RETURN * CONT STA BADDR SAVE THE SOURCE BUFFER ADD. LDB SADDR RESTORE FILTER BUFFER POINTER LDA ICNT UPDATE CHAR COUNT NXT ADA STGCT SSA,RSS JMP EXCHK STA ICNT CLA RESET THE STRING STA STGCT COUNTER LDA JCNT SSA JMP NXBT JMP EXFND * EXCHK LDA JCNT SSA JMP EXNFD * EXFND CCA STA IFLAG,I JMP NAMCK,I * DONE LDA STGCT CEHCK IF PENDING STRING SZA,RSS JMP EXFND NO, SO JUST EXIT FOUND LDA PLSFG CHECK FOR PLUS FLAG SZA,RSS JMP DN.1 LDA ICNT STA OUTLG SAVE LOOP COUNTER ADA STGCT CHECK FOR ILLEGAL STRING LENGTH SZA,RSS CHECK FOR ZERO JMP *+3 IF STGCT + ICNT <= 0 SSA,RSS AND NEGITIVE NUMBER JMP EXNFD PLUS NUMBER: NO GOOD DN.1 JSB CHECK YES, SO GO CHECK STRING JMP EXFND STRING FOUND * * CONSTANTS AND STORGE PLSFG NOP PLUS FLAG SET BADDR NOP SOURCE STRING ADD. POINTER SADDR NOP FILTER STRING ADD. POINTER OUTLG NOP OUTER LOOP COUNTER ICNT NOP SOURCE CHAR. COUNT JCNT NOP FILTER CHAR. COUNT STGCT NOP CURRENT STRING COUNTER M1 DEC -1 AMINS OCT 55 APLUS OCT 53 END