FTN4,L PROGRAM CDA4 (4,90),24999-16197 REV. 2024 781107 C C THE CRASH DUMP ANALYSER -- MAINLINE C C MIKE MANLEY RTE IV VERSION C 11/07/78 EFH C 01/16/80 JEF C C-------------------------------------------------------------------- IMPLICIT INTEGER (A-Z) REAL REG,REIO COMMON /CDA/LU1, LU2, BPFLAG, MPFLAG, IOREC, SOREC, IERR, IWRN, & HIDEBP, HIDEMP, FIOPEN, INTER, IDCB(144), SDCB1(144), & SDCB2(144), IBUF(128), SBUF1(128), SBUF2(128), TRTAB(64) C COMMON /CDASG/ RTNA, IPBUF(33), IPRAM(6), IARRAY(64), IDISC(36), & IGO(35), IGO2(35), IFILE(10), JBUF(30), IOP, LEN, IMAP(35) C DIMENSION IREG(2), ISKP(6), IMCOD(4), MES1(17) C EQUIVALENCE(IREG,REG,IA),(IREG(2),IB) EQUIVALENCE(IPBUF(2),IPRS1),(IPBUF(6),IPRS2),(IPBUF(10),IPRS3) EQUIVALENCE(IPBUF(14),IPRS4),(IPBUF(18),IPRS5) EQUIVALENCE(IPBUF(22),IPRS6),(IPBUF(26),IPRS7) EQUIVALENCE(IPBUF(30),IPRS8) C DATA ISKP /2HLL,2HFI,2H/E,2HEX,2HEN,2H??/ DATA IMCOD /2HPH,2HDP,2HSY,2HUS/ DATA MES1 /2H--,2H C,2HOM,2HMA,2HND,2H C,2HAN,2H'T,2H B,2HE , & 2HUS,2HED,2H I,2HN ,2H--,2H M,2HAP/ C C INITIALIZE VARIABLES, OPEN FILES WITH INIT SUBROUTINE C C---------------------------------------------------------------------- C C DRTN IS AN ASSEMBLER ROUTINE THAT RETURNS THE ADDRESS THAT C IT WAS CALLED FROM. IN THIS PROGRAM, IT IS USED TO MAKE SEGMENTS C LOOK AS IF THEY WERE SUBROUTINES. IMMEDIATELY BELOW, IOP2 IS SET TO C 1 BEFORE CALLING DRTN AND EXECUTING THE SEGMENT. WHEN THE SEGMENT C CALLS THE JMP FUNCTION, IT RETURNS TO THE FIRST STATEMENT AFTER C THE CALL TO DRTN. SINCE IOP2 IS NOW ZERO, THE MAINLINE CONTINUES C RATHER THAN CALLING THE SEGMENT AGAIN. C C---------------------------------------------------------------------- IOP2 = 1 RTNA = DRTN(0) IF(IOP2.EQ.0)GO TO 1 IOP2 = 0 IOP = 0 CALL EXEC(8,6HCDA4A ) C C SET UP THE IPRAM BUFFER. THIS BUFFER IS USED BY THE I/O C SUBROUTINES (DOIO & DISC3) TO DETERMINE HOW THE I/O IS C TO BE DONE. C 1 IF(IWRN.NE.0) CALL PRNT(32H16WARNING: DEAD AREA PROCESSED!!) IWRN = 0 BPFLAG = HIDEBP MPFLAG = HIDEMP IPRAM = 1 IPRAM(2) = 0 IPRAM(3) = 0 IPRAM(4) = 0 IPRAM(5) = 0 IPRAM(6) = -1 CALL EXEC(2,LU1+ 2000B,2H= ,-2) REG = REIO(1,LU1 + 400B,JBUF,-30) LEN = IB IF(IB.LT.2)GO TO 1 CALL PARSE(JBUF,IB,IPBUF) C C SEE IF THE PACKED FORM OF THE OUTPUT IS DESIRED C IF(IPBUF(3).EQ.2HPK) IPRAM(5) = 1 C C IF LU2 NOT = LU1, PRINT COMMAND TO LU2 C IF(IPRS1.EQ.2HEP .OR. IPRS1.EQ.2HLL)GO TO 19 IF(INTER.EQ.-1)GO TO 19 CALL EXEC(2,LU2,2H ,1) CALL EXEC(2,LU2,JBUF,-LEN) CALL EXEC(2,LU2,2H ,1) C C CHECK FOR A FEW SPECIAL COMMANDS THAT DON'T USE THE CRASH FILE C DO 14 I = 1,6 IF (IPRS1.EQ.ISKP(I)) GO TO 19 14 CONTINUE IF(FIOPEN.EQ.1)GO TO 19 CALL EXEC(2,LU1,30HCRASH FILE HAS NOT BEEN OPENED,15) GO TO 1 C C***** FIND OUT WHICH COMMAND IT WAS C 19 IERR = 0 HIDEBP = BPFLAG HIDEMP = MPFLAG DO 20 I = 1,35 IF (IGO(I).EQ.IPRS1) GO TO 25 20 CONTINUE CALL IWSUB(LU1) GOTO 1 C C CHECK THE MAP IS OK FOR THIS COMMAND C 25 IF(MPFLAG.EQ.0 .AND. IAND(IMAP(I),1).NE.0) GO TO 30 IF(MPFLAG.EQ.1 .AND. IAND(IMAP(I),2).NE.0) GO TO 30 IF(MPFLAG.EQ.2 .AND. IAND(IMAP(I),4).NE.0) GO TO 30 IF(MPFLAG.EQ.3 .AND. IAND(IMAP(I),8).NE.0) GO TO 30 C C IT'S NOT - PRINT AN ERROR MESSAGE C MES1( 1) = IPRS1 MES1(15) = IMCOD(MPFLAG+1) CALL EXEC(2,LU1,MES1,17) GO TO 1 C C SET UP A RETURN ADDRESS C 30 IOP2 = 1 RNTA = DRTN(0) IF(IOP2.EQ.0)GO TO 1 C C CALL SEGMENT AS REQUIRED C 40 IOP2 = 0 IOP = I IF (IGO2(I).NE.1) GO TO 50 CALL EXEC(8, 6HCDA4A ) 50 IF (IGO2(I).NE.2) GO TO 60 CALL EXEC(8, 6HCDA4B ) 60 GO TO (101, 102, 103, 104, 105, 106, 107, 108, 109, 110, & 111, 112, 100, 100, 100, 100, 100, 100, 100, 120, & 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, & 100, 100, 100, 100, 100) I C C INTERNAL ERROR IF WE GET TO 100 C 100 CALL EXEC(2,LU1,14HINTERNAL ERROR,7) GO TO 1 C C SUBROUTINE CALLS C 101 GO TO 1 C 102 CONTINUE 103 CONTINUE 104 CALL EXSUB GO TO 1 105 CALL QUSUB(IPRS2) GO TO 1 106 CALL LMSUB(IPRS2, IPRS3, IPRAM, LU2, LU1) GO TO 1 107 CALL LLSUB(IPRS2, INTER, LU2, LU1) GO TO 1 108 CALL TRSUB(IPRS2, IPRS3, IPRS4, IPRS5, IPRAM, LU2) GO TO 1 109 CALL DPSUB(IPRS2, IPRS3, IPRS4, LU2) GO TO 1 110 CALL DUSUB(IPRAM, LU2) GO TO 1 111 CALL MPSUB(IPRS2) GO TO 1 112 CALL BPSUB(IPRS2) GO TO 1 120 CALL EXEC(3,LU2+700B,-1) GO TO 1 END C C C ILLEGAL COMMAND C C SUBROUTINE IWSUB(LU1) DIMENSION IWHAT(6) DATA IWHAT/2H ,2HSA,2HY ,2HWH,2HAT,2H ?/ CALL EXEC(2,LU1,IWHAT,-12) RETURN END C C *****OUT OF RANGE MESSAGE***** C SUBROUTINE ITSUB(LU1) DIMENSION IOUT(7) DATA IOUT/2H ,2HOU,2HT ,2HOF,2H R,2HAN,2HGE/ CALL EXEC(2,LU1,IOUT,7) RETURN END C C *****NOT FOUND MESSAGE***** C SUBROUTINE NFSUB(ITEM,LU1) DIMENSION IMES11(9),ITEM(3) DATA IMES11/2H ,2H ,2H ,2H ,2HNO,2HT ,2HFO,2HUN,2HD / DO 60 I = 1,3 IMES11(I) = ITEM(I) 60 CONTINUE CALL EXEC(2,LU1,IMES11,9) RETURN END C C *****EXIT STUFF***** C SUBROUTINE EXSUB IMPLICIT INTEGER (A-Z) COMMON /CDA/ LU1, LU2, BPFLAG, MPFLAG, IOREC, SOREC, IERR, IWRN, & HIDEBP, HIDEMP, FIOPEN, INTER, IDCB(144), SDCB1(144), & SDCB2(144), IBUF(128), SUBF1(128), SBUF2(128), TRTAB(64) C C UNLOCK ALL DEVICES AND CLOSE FILES C CALL LURQ(100000B, LU2-200B, 1) IF (FIOPEN.EQ.1) CALL CLOSE (IDCB,IERR) CALL ERR CALL CLOSE (SDCB1,IERR) CALL ERR CALL CLOSE (SDCB2,IERR) CALL ERR CALL EXEC(2,LU1,16H =CDA4 DONE ! ,-16) CALL EXEC(6,0) RETURN END C C C*****LIST ANY MEMORY LOCATION REQUESTED***** C C SUBROUTINE LMSUB(IPRS2,IPRS3,IPRAM,LU2,LU1) DIMENSION IPRAM(6) C C L1 = IPRS2 L2 = L1 - 1 + IPRS3 IF(IPRS3.EQ.0) L2 = L1 IF(IPRS3.LT.0) L2 = - IPRS3 IF (L1.LT.0) GO TO 450 CALL DOIO(L1,L2,LU2,IPRAM) RETURN 450 CALL ITSUB(LU1) RETURN END C C*****CHANGE OUTPUT LU***** C SUBROUTINE LLSUB(IPRS2,INTER,LU2,LU1) C C CHECK IF LEGAL LU C CALL LURQ(100000B,0,0) CALL EXEC(100015B,IPRS2,ISTA1) GO TO 650 C C VALID LU # -- CHECK FOR INTERACTIVE (LOCK IF NOT) C 640 INTER = IFTTY(IPRS2) LU2 = IPRS2+200B 641 IF(INTER.EQ.-1) RETURN CALL LURQ(100001B,LU2-200B,1) CALL ABREG(IA,IB) IF(IA.EQ.0) RETURN IF(IA.EQ.-1) GO TO 18 CALL EXEC(2,LU1,14HWAITING FOR LU,7) GO TO 16 18 CALL EXEC(2,LU1,14HWAITING FOR RN,7) 16 CALL EXEC(12,0,1,0,-100) IF(IFBRK(IDMY).NE.-1) GO TO 641 RETURN C C INVALID LU # C 650 CALL IWSUB(LU1) RETURN END C C C******************* TRACE A LIST IN ANY MAP ************************** C SUBROUTINE TRSUB(IPRS2,IPRS3,IPRS4,IPRS5,IPRAM,LU2) DIMENSION IPRAM(6) C C THIS ROUTINE TRACES A LIST STARTING AT IPRS2 UNTIL C THE VALUE IPRS3 IS FOUND. IPRS4 IS ADDED IN AS AN OFFSET, C AND IPRS5 IS AN UPPER LIMIT ON THE NUMBER OF LINKS TO C FOLLOW C---------------------------------------------------------------------- C IPRL2 = IPRS2 I = 0 GO TO 1615 C 1610 IF(IPRL2.LT.0 .OR. IPRL2.EQ.IPRS3) RETURN IPRL2 = IPRL2 + IPRS4 1615 CALL DOIO(IPRL2,IPRL2,LU2,IPRAM) I = I + 1 IF(I.EQ.IPRS5 .OR. IPRAM(3).EQ.9999) RETURN IPRL2 = IPRL2 IPRAM(3) = 1 IPRL2 = IGET(IPRL2) IF(IFBRK(IDMY))1620,1610 1620 RETURN END C C*********DISPLAY WHATEVER THE USER HAS INPUT ************ C C SUBROUTINE DPSUB(IPRS2,IPRS3,IPRS4,LU2) IMPLICIT INTEGER (A-Z) DIMENSION IARRAY(64),IDISC(36),IPRAM(6) DIMENSION MES1(22),MES2(36) C DATA MES1/2H22,2H ,2HVA,2HLU,2HE(,2H8),2H ,2HVA,2HLU,2HE(, & 2H10,2H) ,2HVA,2HLU,2HE(,2HAS,2H) ,2HVA,2HLU,2HE(, & 2HSY,2HM)/ DATA MES2/ 2H ,2H ,2H..,2H..,2H..,2H ,2H ,2H..,2H.., & 2H..,2H ,2H ,2H ,2H..,2H ,2H ,2H..,2H..,2H.., & 2H..,2H..,2H..,2H..,2H..,2H..,2H..,2H..,2H..,2H.., & 2H..,2H..,2H..,2H..,2H..,2H../ C IF(IPRS3.EQ.0) GO TO 1750 IF(IPRS3.EQ.2H* )IPRS2 = IPRS2*IPRS4 IF(IPRS3.EQ.2H+ )IPRS2 = IPRS2+IPRS4 IF(IPRS3.EQ.2H/ )IPRS2 = IPRS2/IPRS4 IF(IPRS3.EQ.2H- )IPRS2 = IPRS2-IPRS4 1750 CALL OCT(IPRS2,MES2(3)) CALL CNUMD(IABS(IPRS2),MES2(8)) IF(IPRS2.LT.0) MES2(8) = MES2(8) + 2H- - 2H CALL IASCI(IPRS2,MES2(14)) CALL INVRS(0,IPRS2,MES2(17),16,RES) CALL PRNT(MES1) CALL EXEC(2,LU2,MES2,RES+16) RETURN END C C C *****DUMP THE SYSTEM TO LIST DEVICE***** C C SUBROUTINE DUSUB(IPRAM,LU2) DIMENSION IPRAM(6) IPRAM(5) = 1 CALL DOIO(0,32767,LU2,IPRAM) RETURN END SUBROUTINE QUSUB(IPRM1) IMPLICIT INTEGER (A-Z) COMMON /CDA/ LU1, LU2, BPFLAG, MPFLAG, IOREC, SOREC, IERR, IWRN, & HIDEBP, HIDEMP, FIOPEN, INTER, IDCB(144), SDCB1(144), & SDCB2(144), IBUF(128), SBUF1(128), SBUF2(128), TRTAB(64) COMMON /QT/ QTTAB(1) COMMON /MEM/ M(1) C C QUSUB IMPLEMENTS THE HELP FUNCTION. IF IPRM1 IS FOUND IN C THE HELP TABLE, THEN A DESCRIPTION OF THAT COMMAND (ONLY) IS C PRINTED. OTHERWISE, A SUMMARY OF ALL COMMANDS IS PRINTED. C C THE DATA TABLE IS QTTAB, AND IS INITIALIZED IN ASSEMBLY CODE. C THE FORMAT OF EACH ENTRY: C C WORD 1 POINTER TO DESCRIPTION C 2 POINTER TO DETAILS C C THE LAST ENTRY IS INDICATED BY A ZERO VALUE IN WORD 1 C C THE DESCRIPTION HAS THIS FORMAT: C C WORD 1 LENGTH (IN ASCII) OF DESCRIPTION (=N) C 2 THE COMMAND CODE C 3-N DESCRIPTION C C THE DETAILED DESCRIPTION CONSISTS OF A SERIES OF TEXT LINES. C EACH LINE HAS THIS FORMAT: C C WORD 1 LENGTH (IN ASCII) C 2 TEXT C C THE END OF THE DESCRIPTION IS INDICATED BY A ZERO (BINARY) WORD C C----------------------------------------------------------------------- C C SEARCH FOR COMMAND C IF(IPRM1.EQ.2H )GO TO 20 DO 10 J = 1,32767,2 IF(QTTAB(J).EQ.0) GO TO 20 IF(M(QTTAB(J)+2).EQ.IPRM1) GO TO 40 10 CONTINUE C C NOT FOUND, PRINT SUMMARY TABLE C 20 CALL PRNT(20H10CMD DESCRIPTION ) CALL PRNT(4H02 ) DO 30 J = 1,32767,2 IF(IFBRK(0).NE.0) RETURN IF(QTTAB(J).EQ.0) RETURN CALL PRNT(M(QTTAB(J)+1)) 30 CONTINUE RETURN C C FOUND, PRINT DETAILS C 40 ADDR = QTTAB(J+1) 50 CALL PRNT(M(ADDR+1)) TEMP = M(ADDR+1) - 2H00 TEMP2 = (TEMP/256) ADDR = ADDR + TEMP - TEMP2*246 IF(M(ADDR+1).NE.0) GO TO 50 RETURN END SUBROUTINE BPSUB(IP) IMPLICIT INTEGER(A-Z) COMMON /CDA/LU1, LU2, BPFLAG, MPFLAG, IOREC, SOREC, IERR, IWRN, & HIDEBP, HIDEMP, FIOPEN, INTER, IDCB(144), SDCB1(144), & SDCB2(144), IBUF(128), SBUF1(128), SBUF2(128), TRTAB(64), & PRFLAG C C SUBROUTINE TO SET THE BASE PAGE FLAG (BP COMMAND) C C------------------------------------------------------------------------- IF(IP.NE.2HON.AND.IP.NE.2HOF)CALL IWSUB(LU1) IF(IP.EQ.2HON) HIDEBP = 1 IF(IP.EQ.2HOF) HIDEBP = 0 RETURN END SUBROUTINE MPSUB(IP) IMPLICIT INTEGER (A-Z) COMMON /CDA/ LU1, LU2, BPFLAG, MPFLAG, IOREC, SOREC, IERR, IWRN, & HIDEBP, HIDEMP, FIOPEN, INTER, IDCB(144), SDCB1(144), & SDCB2(144), IBUF(128), SBUF1(128), SBUF2(128), TRTAB(64), & PRFLAG COMMON /CDA2/ DS1, DS2, MLIM, MSTAT, DPLIM C C SUBROUTINE TO SET THE MAP FLAG (MP COMMAND) C C------------------------------------------------------------------------- IF(IP.NE.2HPH.AND.IP.NE.2HSY.AND.IP.NE.2HUS.AND.IP.NE.2HDP) & CALL IWSUB(LU1) IF(IP.EQ.2HPH) HIDEMP = 0 IF(IP.EQ.2HDP) HIDEMP = 1 IF(IP.EQ.2HSY) HIDEMP = 2 IF(IP.EQ.2HUS) HIDEMP = 3 IF(HIDEMP.LE.MLIM) RETURN CALL PRNT(30H15REQUESTED MAP IS NOT IN DUMP) HIDEMP = MPFLAG RETURN END SUBROUTINE ERR IMPLICIT INTEGER (A-Z) COMMON /CDA/ LU1, LU2, BPFLAG, MPFLAG, IOREC, SOREC, IERR, IWRN, & HIDEBP, HIDEMP, FIOPEN, INTER, IDCB(144), SDCB1(144), & SDCB2(144), IBUF(128), SBUF1(128), SBUF2(128), TRTAB(64), & PRFLAG DIMENSION MES1(11) DATA MES1/2HFI,2HLE,2H I,2H/O,2H E,2HRR,2HOR,2H -,2H--,2H--,2H--/ * * ERR PRINTS THE ERROR NUMBER FOR FILE I/O (IE, IF IERR IS < 0) * IF(IERR.GE.0)RETURN CALL CNUMD(IABS(IERR), MES1(9)) CALL EXEC(2,LU1,MES1,11) RETURN END BLOCK DATA CDA,BLOCK DATA FOR CDA4 IMPLICIT INTEGER (A-Z) COMMON /CDA/ LU1, LU2, BPFLAG, MPFLAG, IOREC, SOREC, IERR, IWRN, & HIDEBP, HIDEMP, FIOPEN, INTER, IDCB(144), SDCB1(144), & SDCB2(144), IBUF(128), SBUF1(128), SBUF2(128), TRTAB(64), & PRFLAG C COMMON /CDA2/ DS1, DS2, MLIM, MSTAT, DPLIM C COMMON /CDASG/ RTNA, IPBUF(33), IPRAM(6), IARRAY(64), IDISC(36), & IGO(35), IGO2(35), IFILE(10), JBUF(30), IOP, LEN, IMAP(35) C DATA IDISC/2H ,2HLU,2H= ,2H ,2H ,2H ,2H ,2HTR,2HK ,2H= , & 2H ,2H ,2H ,2H ,2HSE,2HCT,2HR ,2H= ,2H ,2H ,2H , & 2H ,2HWO,2HRD,2H =,2H ,2H ,2H ,2H ,2HOL,2HD(,2H8), & 2H =,2H ,2H ,2H / DATA IGO /2H**,2HEX,2HEN,2H/E,2H??,2HLM,2HLL,2HTR,2HDP,2HDU, & 2HMP,2HBP,2HID,2HEQ,2HDR,2HIN,2HCT,2HF/,2HLI,2HEP, & 2HTA,2HCM,2HMA,2HDB,2HWH,2H**,2HAN,2HFI,2H**,2HVE, & 2H**,2H**,2H**,2H**,2H**/ DATA IGO2 / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 0, 0, 1, 1, 1, 1, 1, 1, 1, 0, & 1, 1, 1, 2, 2, 2, 1, 2, 1, 2, & 0, 0, 0, 0, 0/ DATA IMAP / 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, & 15, 15, 5, 5, 5, 5, 5, 15, 5, 15, & 5, 7, 15, 15, 5, 0, 5, 15, 0, 5, & 0, 0, 0, 0, 0/ C C IGO AND IGO2 DEFINE THE COMMANDS: IGO HAS THE ABBREVIATIONS, C AND IGO2 INDICATES WHICH SEGMENT HAS THE COMMAND. IGO2 = 0 C INDICATES THE MAIN, 1 INDICATES CDA4A, AND 2 INDICATES CDA4B C C IMAP INDICATES WHICH MAPS ARE ALLOWED FOR EACH COMMAND. BIT 0 C IS FOR PH, 1 FOR DP, 2 FOR SY, AND 3 FOR US C C NOTE THAT COMMON AREAS MEM, CT, AND CTPR ARE DEFINED IN ASSEMBLER C END END$ FTN4,Q,L,T SUBROUTINE DOIO(ISTART,ISTOP,LU,IPRAM) DIMENSION IBUF(40),IMESS(29),IPRAM(6),LMESS(17) DIMENSION IPAGE(11) INTEGER OBUF(37) C DATA IMESS/2H ,2HWO,2HRD, &2H ,2HLO,2HCA,2HTI,2HON,2H , &2HVA,2HLU,2HE(,2H8),2H ,2HVA,2HLU,2HE(,2H10,2H) , &2HVA,2HLU,2HE(,2HAS,2H) ,2HVA,2HLU,2HE(,2HSY,2HM)/ DATA IPAGE/2H ,2HPH,2HYS,2HIC,2HAL,2H P,2HAG,2HE / DATA LMESS/2H ,2HLO,2HCA,2HTI,2HON,2HS ,2H ,2H ,2H , &2H T,2HHR,2HOU,2HGH,2H / DATA IBUF/40*2H / C C C THE IPRAM ARRAY TELLS HOW TO DO THE I/O C IPRAM(1) = WORD # TO START COUNTING AT, C IPRAM(2) = 0 MEANS WORD COUNT TO BE IN DECIMAL C IPRAM(2) = 1 MEANS WORD COUNT TO BE IN OCTAL C IPRAM(3) = 0 MEANS PRINT HEADER. = 1 MEANS NO HEADER. C IPRAM(5) = 1 MEANS A PACKED LISTING IS DESIRED C IPRAM(6) =+N MEANS A MAPPED IN LISTING OF PHYS MEMORY C WHERE N = PHYSICAL PAGE NUMBER C IPRAM(6) =-1 MEANS WE ARE DOING NORMAL I/O C C ISTART IS LOCATION TO START COUNTING AT C ISTOP IS LOCATION TO STOP COUNTING AT. C LU IS THE OUTPUT LU. C C K = IPRAM-1 C IF(IPRAM(5).EQ.1) GO TO 500 C IF(IPRAM(6).LT.0) GO TO 1 CALL CNUMD(IPRAM(6),IPAGE(9)) CALL EXEC(2,LU,IPAGE,11) 1 IF(IPRAM(3).EQ. 0) CALL EXEC(2,LU,IMESS,-58) C C DO 100 I = ISTART,ISTOP K = K + 1 IF((IPRAM(6).LT.0).OR.(K.NE.1024)) GO TO 2 K = 0 IPRAM(6) = IPRAM(6) + 1 2 CALL CNUMD(K,IBUF(1)) IF(IPRAM(2) .EQ.1) CALL CNUMO(K,IBUF(1)) CALL CNUMO(I,IBUF(5)) IF(IPRAM(6).LT.0) GO TO 50 CALL CNUMD(IPRAM(6),IBUF(5)) IBUF(5) = 2HPG 50 CALL CNUMO(IGET(I),IBUF(10)) CALL CNUMD(IABS(IGET(I)),IBUF(15)) IF (IGET(I).LT.0) IBUF(15) = IBUF(15) + 6400B C CALL IASCI(IGET(I),IBUF(22)) CALL INVRS(I,IGET(I),IBUF(25),16,IWRD) C 75 CALL EXEC(2,LU,IBUF,24+IWRD) IF(IFBRK(IDMY))200,100 100 CONTINUE GO TO 300 200 IPRAM(3) = 9999 300 RETURN C C 500 K = ISTART 550 IF((ISTOP-K).LT.0) RETURN CALL CNUMO(K,LMESS(7)) CALL CNUMO(ISTOP,LMESS(15)) IF(((ISTOP-K)/64).GT.0) CALL CNUMO(K + 63,LMESS(15)) C IF(IPRAM(6).LT.0) GO TO 551 CALL CNUMO(IPRAM,LMESS(7)) CALL CNUMO(IPRAM+ISTOP - ISTART,LMESS(15)) CALL CNUMD(IPRAM(6),IPAGE(9)) C 551 CALL EXEC(3,LU + 700B,1) IF(IPRAM(6).GE.0) CALL EXEC(2,LU,IPAGE,11) CALL EXEC(2,LU,LMESS,17) CALL EXEC(3,LU + 700B,1) C DO 800 I = 1,8 C CALL PACK (ISTOP - K + 1,IPRAM(4)+1,K,OBUF) CALL EXEC(2,LU,OBUF,37) C K = K + 8 IF((ISTOP-K).LT.0) RETURN IF(IFBRK(IDMY)) 200,800 800 CONTINUE C GO TO 550 END INTEGER FUNCTION IGET(IADDR) IMPLICIT INTEGER (A-Z) COMMON /CDA/LU1, LU2, BPFLAG, MPFLAG, IOREC, SOREC, IERR, IWRN, & HIDEBP, HIDEMP, FIOPEN, INTER, IDCB(144), SDCB1(144), & SDCB2(144), IBUF(128), SBUF1(128), SBUF2(128), TRTAB(64) COMMON /CDA2/ DS1, DS2, MLIM, MSTAT, DPLIM C C IGET - FETCHES A WORD FROM THE APPROPRIATE MAP (PH, SY, US) C BY READING FROM THE CRASH FILE. IF THE BASE PAGE FLAG C IS ON, AND THE MAP IS PH OR SY, THEN THE BASE PAGE FROM C THE SNAPSHOT IS SUBSTITUTED. C C RECORDS IN THE CRASH FILE ARE 128 WORDS LONG. RECORDS 1-256 C CONTAIN THE IMAGE OF THE FIRST 32K OF PHYSICAL MEMORY; C RECORD 257 CONTAINS THE FOUR MAPS (S,U,A,B); C C RECORDS 258-K CONTAIN THE DRIVER PARTITIONS (THE EXACT C NUMBER OF BLOCKS IS DETERMINED BY $MRMP IF THE DUMP C WAS FROM THE GENNED IN DUMPER; OTHERWISE 48K IS USED AS C A DEFAULT. IF THE CONTENT OF $MRMP IS <=32, 32K IS DUMPED; C IF THE VALUE IS BETWEEN 32 AND 63, THAT VALUE IS USED; C OTHERWISE 48K IS DUMPED. SINCE THE FIRST 32K ARE AT THE C BEGINNING OF THE TAPE, THIS PART OF THE FILE ONLY HAS THE C REMAINDER (E.G., FOR A 48K DUMP, THERE IS 16K HERE.) C C RECORDS K+1-N C CONTAIN THE PHYSICAL PAGES IN THE SYSTEM MAP AND IN THE USER C MAP THAT ARE NOT PART OF THE BLOCK OF PHYSICAL MEMORY DUMPED C AS DESCRIBED ABOVE (BETWEEN 32 AND 64K). C C TRTAB IS USED TO MAP FROM SYSTEM/USER MAPS TO RECORD ADDRESSES. C C MPFLAG CODES: C 0 - PHYS MEM (1ST 32K) 1 - DVR PTTNS (REST OF PHYS MEM) C 2 - SYSTEM MAP 3 - USER MAP C C----------------------------------------------------------------------- C IF (IADDR.LT.0)CALL EXEC(2,LU1,24HNEGATIVE ADDRESS IN IGET,12) C C IF BASE PAGE SWITCH IS ON, WORD IS IN BASE PAGE, AND NOT IN C USER MAP, CALL SGET TO FETCH FROM SNAPSHOT C IF (BPFLAG.EQ.0.OR.IADDR.GT.1023.OR.MPFLAG.EQ.1.OR.MPFLAG.EQ.3) & GO TO 10 IGET=SGET(IADDR) RETURN C C COMPUTE THE RECORD NUMBER C 10 IPAGE = IADDR/1024 IWORD = IADDR - IPAGE*1024 IF(MPFLAG.EQ.0) IREC = 1 + IADDR/128 IF(MPFLAG.EQ.1) IREC = 258 + IADDR/128 IF(MPFLAG.EQ.2) IREC = TRTAB(IPAGE + 1) + IWORD/128 IF(MPFLAG.EQ.3) IREC = TRTAB(IPAGE + 33) + IWORD/128 IF(MPFLAG.NE.1 .OR. IADDR.LT.(DPLIM-32)*1024) GO TO 15 IOREC = 0 IGET = 0 IWRN = 1 RETURN C 15 IWD2 = IWORD - (IWORD/128)*128 C C SET THE IWRN FLAG IF DATA FROM THE DEAD AREA IS SELECTED C IADD2 = (IREC-1)*128 + IWD2 IF(IADD2.GE.DS1.AND.IADD2.LE.DS2) IWRN = 1 C C READ IN THE APPROPRIATE RECORD (ONLY IF IT IS NOT IN THE BUFFER) C IF (IOREC.NE.IREC) CALL READF(IDCB,IERR,IBUF,128,IDMY,IREC) IF (IERR.NE.-12) GO TO 20 IOREC = 0 IGET = 0 RETURN 20 CALL ERR IGET = IBUF(IWD2 + 1) IOREC = IREC RETURN END INTEGER FUNCTION SGET(IADDR) IMPLICIT INTEGER (A-Z) COMMON /CDA/LU1, LU2, BPFLAG, MPFLAG, IOREC, SOREC, IERR, IWRN, & HIDEBP, HIDEMP, FIOPEN, INTER, IDCB(144), SDCB1(144), & SDCB2(144), IBUF(128), SBUF1(128), SBUF2(128), TRTAB(64) C C SGET FETCHES A WORD FROM THE SNAPSHOT OF THE SYSTEM. THE C FILE HAS NO STRUCTURE; IT CONTAINS 32K WORDS OF THE SYSTEM C PLUS THE DRIVER PARTITIONS C (256 + N RECORDS OF 128 WORDS EACH). C IF (IADDR.LT.0) CALL EXEC(2,LU1,24HNEGATIVE ADDRESS IN SGET,12) IREC = IADDR/128 + 1 IF(MPFLAG.EQ.1) IREC = IREC + 256 IF (IREC.NE.SOREC) CALL READF(SDCB2,IERR,SBUF2,128,IDMY,IREC) IF (IERR.NE.-12) GO TO 10 SGET = 0 SOREC = 0 IWRN = 1 RETURN 10 CALL ERR SGET = SBUF2(IADDR - (IREC - 1)*128 + 1) SOREC = IREC RETURN END SUBROUTINE OCT(NUM,BUF) IMPLICIT INTEGER (A-Z) DIMENSION BUF(3) C C OCT CONVERTS A NUMBER TO OCTAL WITH LEADING ZEROS C CALL CNUMO(NUM,BUF) DO 10 J = 1,3 BUF(J) = IOR(BUF(J),2H00) 10 CONTINUE RETURN END END$ ASMB,Q,C NAM INVRS,7 * * THIS ROUTINE INVERSE ASSEMBLES HP 21MX * INSTRUCTIONS * * THE CALLING SEQUENCE IS AS FOLLOWS * * JSB INVRS * DEF RTRN * DEF ADDRSS LOGICAL ADDRESS OF INSTRUCTION * DEF VALUE INSTRUCTION AT ADDRSS * DEF IBUF OUTPUT BUFFER * DEF ISIZE SIZE OF OUTPUT BUFFER * DEF IWRDS RETURNED NO OF WORDS FILLED * RTRN ... * * FORTRAN CALL: * * CALL INVRS(IADRS,VALUE,IBUF,ISIZE,IWRDS) * * ENT INVRS EXT .ENTR * * A EQU 0 B EQU 1 * * ADDRS BSS 1 VALUE BSS 1 BUFAD BSS 1 BSIZE BSS 1 WCNT BSS 1 INVRS NOP JSB .ENTR DEF ADDRS LDA BUFAD RAL MAKE BYTE ADDRESS STA BUFAD STA BPNTR LDB BSIZE,I GET BUFFER SIZE RBL MAKE INTO BYTES ADA B COMPUTE END OF BUFFER STA BFEND LDA ADDRS,I STA IADR SAVE ADDRESS OF INSTRUCTION LDA B2 SET NO OF WORDS/ENTRY STA INCR IN INCREMENT JSB LOAD FETCH INSTRUCTION STA INSTR STA TEMP AND B70K IS IT A MEMORY REFERENCE SZA JMP MRGI YES GO GET IT LDA INSTR NO ELA,ALF PUT SIGN IN E REG RAL AND BITS 10&11 IN BITS 0&1 SEZ IF E SET(I.E. SIGN) MUST BE I/O OR EIG JMP IOGI * AND B3 SET UP OP CODE TABLE COUNTER LDB M18 SHIFT ROTATE SLA LDB M12 ALTER SKIP STB CNTR ADA GRTBL GET ADDRESS OF GROUP TABLE LDB A,I * LOOP1 LDA TEMP FETCH REMAINING BITS OF INSTRUCTION AND B,I ARE ALL REQUIRED BITS SET XOR B,I SZA,RSS JMP FOND1 YES GO GET MNEMONIC LOP1A ADB INCR BUMP ADDRESS ISZ CNTR JMP LOOP1 * NFND LDA BUFAD IF WE FALL THROUGH NOT COMPLETELY STA BPNTR DEFINED SO JUST PRINT OCTAL LDA INSTR JSB PN JMP EXIT * IADR BSS 1 INCR BSS 1 INSTR BSS 1 TEMP BSS 1 CNTR BSS 1 BPNTR BSS 1 * B2 OCT 2 B3 OCT 3 B70K OCT 70000 M12 DEC -12 M18 DEC -18 BFEND BSS 1 * GRTBL DEF *+1 DEF SRGA DEF ASGA DEF SRGB DEF ASGB * MRGA1 DEF MRG-4 * FOND1 JSB POPCD PRINT MNEMONIC LDA B,I REMOVE OPCODE FROM AND B1777 INSTRUCTION XOR TEMP STA TEMP AND B1777 ARE ANY BITS LEFT SZA,RSS JMP EXIT NO,THEN RETURN LDA COMMA JSB TYO PRINT COMMA JMP LOP1A GO LOOK FOR REST * B1777 OCT 001777 COMMA OCT 54 * MRGI LDA INSTR ALF,RAL AND B17 RAL TIMES 2 ADA MRGA1 COMPUTE TABLE POSITION LDB A JSB POPCD PRINT MNEMONIC LDA INSTR COMPUTE ADDRESS AND B2000 MERGE WITH PROPER PAGE SZA LDA IADR XOR INSTR AND B76K XOR INSTR JSB PADR PRINT ADDRESS JMP EXIT * B17 OCT 17 B2000 OCT 2000 B76K OCT 76000 * IOGI LDB IOGTB FETCH TABLE OF LOOP FOR I/O SLA,RSS IF EIG INSTEAD LDB DSGTB THEN GET TABLE FOR EIG'S STB PNTR PARMETERS LDB PNTR,I SET B TO START ISZ PNTR LOOP2 LDA PNTR,I GET COUNT FOR THIS TYPE SSA JMP LOP2A IF NEGATIVE CONTINUE * SZA,RSS IF ZERO THEN DONE JMP NFND LDA B3 STA INCR ELSE SET INCREMENT TO 3 LDA PNTR,I AND MAKE COUNT NEGATIVE CMA,INA * LOP2A STA CNTR ISZ PNTR LOOP3 LDA INSTR FETCH INSTRUCTION XOR B,I SEARCH FOR MATCH AND PNTR,I MASK UNWANTED BITS SZA,RSS JMP FOND2 ADB INCR BUMP ADDRESS IN OPCTBL ISZ CNTR DONE WITH THIS TYPE JMP LOOP3 NO CONTINUE ISZ PNTR JMP LOOP2 YES GO TO NEXT TYPE * * PNTR BSS 1 * FOND2 JSB POPCD GO PRINT MNEMONIC LDA PNTR,I FETCH MASK CMA IF EXACT NO OPERAND IN SAME WORD AND B77 SZA,RSS JMP OPRND * AND INSTR STRIP OFF OPERAND STA TEMP SAVE FOR COMMA C TEST LDB PNTR,I IS MASK FOR CPB DSMSK A DOUBLE SHIFT GROUP SZA AND OPERAND EQUAL 0 RSS LDA B20 YES MAKE OPERAND IT 16 AND B77 AND MASK C BIT JSB PNUMB GO PRINT NUMBER LDA TEMP AND B1000 IS A COMMA C REQUIRED SZA,RSS NO RETURN JMP EXIT LDA COMMA JSB TYO PRINT COMMA LDA "C JSB TYO PRINT "C" JMP EXIT * * * PRINTS MULTI WORD OPERANDS * OPRND LDA TFLAG TRACING SZA,RSS JMP EXIT NO THEN RETURN * * MUTIWORD PRINT HERE * JMP EXIT * * TFLAG OCT 0 * B20 OCT 20 B77 OCT 77 B1000 OCT 1000 "C OCT 103 * * * PRINT ONE CHARACTER * TYO NOP STB TEMP2 SAVE B REG LDB BPNTR CPB BFEND JMP EXIT IF FULL THEN COMPLETE SBT ELSE STORE BYTE STB BPNTR UPDATE POINTER LDB TEMP2 RESTORE B REG JMP TYO,I * IOGTB DEF *+1 DEF OVFG DEC -4 OVERFLOW GROUP OCT 177777 DEC -1 CLF OCT 177700 DEC -12 I/O GROUP OCT 176700 OCT 0 INDICATES END OF IO TABLE DSGTB DEF *+1 DEF DSG DEC -6 DOUBLE SHIFT GROUP DSMSK OCT 5760 DEC -90 REST OF BASE SET OCT 5777 * MICROCODED INSTRUCTIONS DEC 27 POSITIVE COUNT MEANS CHANGE INCREMENT OCT 5777 OCT 0 THIS INDICATES END * LOAD NOP LDA VALUE,I JMP LOAD,I * TEMP2 BSS 1 * * PRINT MNEMONIC POPCD NOP STB TEMP3 INB LDA B,I FETCH FIRST 3 CHARS JSB DSQZ GO PRINT THEM LDA INCR CPA B2 DOES MNEMONIC HAVE MORE THAN 3 CHARS JMP POP1 NO,GO TO RETURN LDB TEMP3 ADB B2 YES FETCH NEXT 3 CHARS LDA B,I JSB DSQZ GO TO PRINT THEM POP1 LDB TEMP3 RESTORE B REG JMP POPCD,I RETURN * * DSQZ NOP CLB A=SQOZE CODE DIV D1600 JSB CONV A=FIRST CHAR,B=2ND,3RD LDA B CLB DIV D40 SPLIT SECOND 2 CHARS JSB CONV LDA B JSB CONV JMP DSQZ,I * * A REG = ONE SQOZE CHARACTER * CONV NOP SZA,RSS IF ZERO THEN TERMINATE DSQZ JMP DSQZ,I * CPA B45 IS IT A "." CCA YES SET TO CONVERT TO 56B ADA M13B IS IT A LETTER SSA,RSS ADA B7 YES ADD 101B ADA B72 NO ADD 57B JSB TYO GO PRINT IT JMP CONV,I RETURN * B7 OCT 7 B45 OCT 45 B72 OCT 72 M13B OCT -13 D40 DEC 40 D1600 DEC 1600 * TEMP3 BSS 1 * * * A =ADDRESS TO BE PRINTED * * PADR NOP PRINT ADDRESS STA SIGN SAVE INDIRECT BIT ELA,CLE,ERA REMOVE SIGN BIT * ************INSERT SYMBOL SEARCH HERE * JSB PNUMB GO PRINT NUMBER LDA SIGN SSA,RSS IS ",I" REQUIRED JMP PADR,I NO THEN RETURN * LDA COMMA YES THEN PRINT ",I" JSB TYO LDA "I JSB TYO JMP PADR,I AND RETURN * "I OCT 111 RADIX DEC 8 * SIGN BSS 1 * * A =NUMBER TO BE PRINTED * PNUMB NOP STA TEMP3 LDA BLANK JSB TYO PRINT BLANK LDA TEMP3 JSB PN PRINT NUMBER JMP PNUMB,I * PN NOP LDB TBADD SET TEMP BUFFER STB TBPTR PN1 CLB CLEAR B FOR DIV DIV RADIX ADB M12B CONVERT TO ASCII SSB,RSS ADB B7 ADB B72 JSB SRBT PUT IN TEMP BUFFER SZA IF QUOTIENT NON ZERO CONTINUE JMP PN1 * LDB TBADD ELSE MOVE TO OUTPUT BUFFER CMB,INB SET UP CHAR COUNT ADB TBPTR STB TEMP3 * PN2 ISZ TBPTR BUMP POINTER LDA TBPTR,I FETCH CHARACTER JSB TYO PRINT CHARACTER ISZ TEMP3 JMP PN2 CONTINUE UNTIL ALL ARE MOVED JMP PN,I AND THEN RETURN * * SRBT NOP SAVE CHARACTERS IN REVERSE ORDER STB TBPTR,I CCB ADB TBPTR DECREMENT POINTER STB TBPTR JMP SRBT,I AND RETURN * BLANK OCT 40 M12B OCT -12 * TBPTR BSS 1 BSS 16 TBADD DEF *-1 * EXIT LDA BLANK FILL WITH BLANK CHAR JSB TYO LDA BUFAD COMPUTE WORD COUNT CMA,INA ADA BPNTR ARS STA WCNT,I JMP INVRS,I AND RETURN * * MRG EQU * MEMORY REFERENCE GROUP AND 0 OCT 044216 JSB 0 OCT 100624 XOR 0 OCT 154204 JMP 0 OCT 100262 IOR 0 OCT 075304 ISZ 0 OCT 075554 ADA 0 OCT 043373 ADB 0 OCT 043374 CPA 0 OCT 052533 CPB 0 OCT 052534 LDA 0 OCT 105673 LDB 0 OCT 105674 STA 0 OCT 134773 STB 0 OCT 134774 SRGA EQU * SHIFT ROTATE GROUP ALF OCT 044100 ELA OCT 060473 ERA OCT 061053 ALR OCT 044114 RAR OCT 130324 RAL OCT 130316 ARS OCT 044475 ALS OCT 044115 OCT 40 CLE OCT 052277 SLA OCT 134273 OCT 27 ALF OCT 044100 OCT 26 ELA OCT 060473 OCT 25 ERA OCT 061053 OCT 24 ALR OCT 044114 OCT 23 RAR OCT 130324 OCT 22 RAL OCT 130316 OCT 21 ARS OCT 044475 OCT 20 ALS OCT 044115 SRGB EQU * BLF OCT 047200 ELB OCT 060474 RBR OCT 130374 RBL OCT 130366 BRS OCT 047575 BLS OCT 047215 OCT 4040 CLE OCT 052277 SLB OCT 134274 OCT 4027 BLF OCT 047200 OCT 4026 ELB OCT 060474 OCT 4025 ERB OCT 061054 OCT 4024 BLR OCT 047214 OCT 4023 RBR OCT 130374 OCT 4022 RBL OCT 130366 OCT 4021 BRS OCT 047575 OCT 4020 BLS OCT 047215 ASGA EQU * ALTER SKIP GROUP CCA OCT 051523 CLA OCT 052273 CMA OCT 052343 SEZ OCT 133674 CCE OCT 051527 OCT 2100 CLE OCT 052277 CME OCT 052347 SSA OCT 134723 SLA OCT 134273 INA OCT 075213 SZA OCT 135353 RSS OCT 131645 ASGB EQU * CCB OCT 051524 CLB OCT 052274 CMB OCT 052344 OCT 6040 SEZ OCT 133674 OCT 6300 CCE OCT 051527 OCT 6100 CLE OCT 052277 OCT 6200 CME OCT 052347 SSB OCT 134724 SLB OCT 134274 INB OCT 075214 SZB OCT 135354 OCT 6001 RSS OCT 131645 OVFG EQU * OVERFLOW GROUP CLO OCT 052311 STO OCT 135011 SOS OCT 134505 SOC OCT 134465 CLF EQU * CLEAR FLAG CLF 0 OCT 052300 IOG EQU * I/O GROUP CLC 0 OCT 052275 STC 0 OCT 134775 OTB 0 OCT 120374 OTA 0 OCT 120373 LIB 0 OCT 106204 LIA 0 OCT 106203 MIB 0 OCT 111304 MIA 0 OCT 111303 SFS 0 OCT 133735 SFC 0 OCT 133715 STF 0 OCT 135000 HLT 0 OCT 072016 DSG EQU * DOUBLE SHIFT GROUP OCT 003100 RRR 1 WORD OCT 131574 OCT 003040 LSR 1 WORD OCT 107044 OCT 003020 ASR 1 WORD OCT 044544 OCT 002100 RRL 1 WORD OCT 131566 OCT 002040 LSL 1 WORD OCT 107036 OCT 002020 ASL 1 WORD OCT 044536 EIG1 EQU * 1 WORD EXTENDED AND DMS GROUP OCT 003741 CAX 1 WORD OCT 051432 OCT 003751 CAY 1 WORD OCT 051433 OCT 007741 CBX 1 WORD OCT 051502 OCT 007751 CBY 1 WORD OCT 051503 OCT 003744 CXA 1 WORD OCT 053233 OCT 007744 CXB 1 WORD OCT 053234 OCT 003754 CYA 1 WORD OCT 053303 OCT 007754 CYB 1 WORD OCT 053304 OCT 007761 DSX 1 WORD OCT 056052 OCT 007771 DSY 1 WORD OCT 056053 OCT 007760 ISX 1 WORD OCT 075552 OCT 007770 ISY 1 WORD OCT 075553 OCT 003747 XAX 1 WORD OCT 153132 OCT 003757 XAY 1 WORD OCT 153133 OCT 007747 XBX 1 WORD OCT 153202 OCT 007757 XBY 1 WORD OCT 153203 OCT 007763 LBT 1 WORD OCT 105576 OCT 007764 SBT 1 WORD OCT 133476 OCT 007767 SFB 1 WORD OCT 133714 OCT 007100 FIX 1 WORD OCT 063432 OCT 007120 FLT 1 WORD OCT 063616 OCT 003727 LFA 1 WORD OCT 106013 OCT 007727 LFB 1 WORD OCT 106014 OCT 007703 MBF 1 WORD OCT 110660 OCT 007702 MBI 1 WORD OCT 110663 OCT 007704 MBW 1 WORD OCT 110701 OCT 007706 MWF 1 WORD OCT 112370 OCT 007705 MWI 1 WORD OCT 112373 OCT 007707 MWW 1 WORD OCT 112411 OCT 003712 PAA 1 WORD OCT 122103 OCT 007712 PAB 1 WORD OCT 122104 OCT 003713 PBA 1 WORD OCT 122153 OCT 007713 PBB 1 WORD OCT 122154 OCT 003730 RSA 1 WORD OCT 131623 OCT 007730 RSB 1 WORD OCT 131624 OCT 003731 RVA 1 WORD OCT 132013 OCT 007731 RVB 1 WORD OCT 132014 OCT 003710 SYA 1 WORD OCT 135303 OCT 007710 SYB 1 WORD OCT 135304 OCT 003711 USA 1 WORD OCT 143123 OCT 007711 USB 1 WORD OCT 143124 OCT 003722 XMA 1 WORD OCT 154043 OCT 007722 XMB 1 WORD OCT 154044 OCT 007720 XMM 1 WORD OCT 154057 OCT 007721 XMS 1 WORD OCT 154065 EIG2 EQU * 2 WORD EXTENDED AND DMS GROUP OCT 010400 DIV 2 WORDS OCT 055230 OCT 014200 DLD 2 WORDS OCT 055376 OCT 014400 DST 2 WORDS OCT 056046 OCT 010200 MPY 2 WORDS OCT 111763 OCT 015000 FAD 2 WORDS OCT 062706 OCT 015060 FDV 2 WORDS OCT 063120 OCT 015040 FMP 2 WORDS OCT 063662 OCT 015020 FSB 2 WORDS OCT 064224 OCT 015746 ADX 2 WORDS OCT 043422 OCT 015756 ADY 2 WORDS OCT 043423 OCT 011742 LAX 2 WORDS OCT 105532 OCT 011752 LAY 2 WORDS OCT 105533 OCT 015742 LBX 2 WORDS OCT 105602 OCT 015752 LBY 2 WORDS OCT 105603 OCT 015745 LDX 2 WORDS OCT 105722 OCT 015755 LDY 2 WORDS OCT 105723 OCT 011740 SAX 2 WORDS OCT 133432 OCT 011750 SAY 2 WORDS OCT 133433 OCT 015740 SBX 2 WORDS OCT 133502 OCT 015750 SBY 2 WORDS OCT 133503 OCT 015743 STX 2 WORDS OCT 135022 OCT 015753 STY 2 WORDS OCT 135023 OCT 015714 SSM 2 WORDS OCT 134737 OCT 011726 XCA 2 WORDS OCT 153223 OCT 015726 XCB 2 WORDS OCT 153224 OCT 011724 XLA 2 WORDS OCT 153773 OCT 015724 XLB 2 WORDS OCT 153774 OCT 011725 XSA 2 WORDS OCT 154423 OCT 015725 XSB 2 WORDS OCT 154424 EIG2J EQU * 2 WORD JUMPS OCT 015762 JLY 2 WORDS OCT 100223 OCT 015772 JPY 2 WORDS OCT 100463 OCT 015732 DJP 2 WORDS OCT 055272 OCT 015733 DJS 2 WORDS OCT 055275 OCT 015734 SJP 2 WORDS OCT 134172 OCT 015735 SJS 2 WORDS OCT 134175 OCT 015736 UJP 2 WORDS OCT 142372 OCT 015737 UJS 2 WORDS OCT 142375 EIG3 EQU * 3 WORD JRS OCT 017715 JRS 3 WORDS OCT 100575 OCT 017766 CBT 3 WORDS OCT 051476 OCT 017765 MBT 3 WORDS OCT 110676 OCT 017776 CMW 3 WORDS OCT 052371 OCT 017777 MVW 3 WORDS OCT 112341 OCT 017774 CBS 3 WORDS OCT 051475 OCT 017773 SBS 3 WORDS OCT 133475 OCT 017775 TBS 3 WORDS OCT 136575 MIC EQU * MICRO CODED MACROS OCT 005201 DBLE 0 FORTRAN CALLABLE OCT 054566 OCT 056700 OCT 005202 SNGL 0 FORTRAN CALLABLE OCT 134421 OCT 104600 OCT 025203 .XMPY 4 WORD(S) OCT 166247 OCT 123770 OCT 025204 .XDIV 4 WORD(S) OCT 166236 OCT 075700 OCT 017205 .DFER 3 WORD(S) OCT 164600 OCT 061040 OCT 025213 .XADD 4 WORD(S) OCT 166233 OCT 054660 OCT 025214 .XSUB 4 WORD(S) OCT 166255 OCT 141640 OCT 177221 .GOTO 31 SPECIAL PROCESSING OCT 165001 OCT 137550 OCT 175222 ..MAP 30 SPECIAL PROCESSING OCT 166437 OCT 044320 OCT 167223 .ENTR 29 SPECIAL PROCESSING OCT 164660 OCT 137740 OCT 167224 .ENTP 29 SPECIAL PROCESSING OCT 164660 OCT 137620 OCT 015225 .PWR2 2 WORD(S) OCT 165561 OCT 127570 OCT 007226 .FLUN 1 WORD(S) OCT 164726 OCT 142600 OCT 015227 .SETP 2 WORD(S) OCT 165727 OCT 137620 OCT 015230 .PACK 2 WORD(S) OCT 165533 OCT 052210 OCT 007220 .XFER 1 WORD(S) OCT 166240 OCT 061040 OCT 015206 .XPAK 2 WORD(S) OCT 166252 OCT 044010 OCT 005207 XADD 0 FORTRAN GALLABLE OCT 153106 OCT 053600 OCT 005210 XSUB 0 FORTRAN CALLABLE OCT 154447 OCT 045400 OCT 005211 XMPY 0 FORTRAN CALLABLE OCT 154062 OCT 155300 OCT 005212 XDIV 0 FORTRAN CALLABLE OCT 153303 OCT 144000 OCT 015215 .XCOM 2 WORD(S) OCT 166235 OCT 117730 OCT 015216 ..DCM 2 WORD(S) OCT 166426 OCT 052330 OCT 005217 DDINT 0 FORTRAN CALLABLE OCT 054703 OCT 115260 OCT 005257 .EMAP 0 FORTRAN CALLABLE OCT 164657 OCT 044320 OCT 005240 .EMIO 0 FORTRAN CALLABLE OCT 164657 OCT 075250 OCT 005241 MMAP 0 FORTRAN CALLABLE OCT 111543 OCT 121200 END END MCEND EQU * END END FTN4,L SUBROUTINE FNDET(IEPN,IERR,IDCB,MYTY,IWRD4) C C C *****GIVEN AN ENTRY POINT NAME THIS SUBROUTINE C FINDS THE ENTRY IN THE SNAPSHOT FILE AND C RETURNS THE TYPE AND THE 4TH WORD OF THE ENTRY C C DIMENSION IEPN(3),IDCB(144),IBUFR(128) C C DO 200 I = 1,32767 CALL READF(IDCB,IERR,IBUFR,128,ILEN,I) IF (IERR.LT.O) GO TO 250 C C DO 100 J = 1,128,4 IF (((IBUFR(J).EQ.IEPN(1)).AND. &(IBUFR(J+1).EQ.IEPN(2))).AND. &(IOR(IAND(IBUFR(J+2),177400B),40B).EQ.IEPN(3))) GO TO 300 C C 100 CONTINUE C C 200 CONTINUE C C 250 IF (IERR.NE.-12) RETURN MYTY = 3 IERR = 0 RETURN C C 300 MYTY = IAND(IBUFR(J+2),177B) +1 IWRD4 = IBUFR(J+3) RETURN END END$ ASMB,L NAM PACK4,7 ENT PACK,IASCI,DUMMY,MAPXX * ENT IGET,IPUT EXT $LIBR,$LIBX,.ENTR,.ENTP,$IDEX,IGET * * * * * * * * * * * * * * * * * THIS ROUTINE ACCEPTS UP TO 8 WORDS OF INPUT AND CONVERTS THOSE * WORDS TO OCTAL ASCII IN A PACKED FORMAT . EIGHT WORDS OF OCTAL * DELIMITED BY A * AND THEN THEIR ASIII REPRESENTATION. * THE WORDS MAY EITHOR BE IN THE CRASHED SYSTEM OR THE 128 * WORDS OF THE MAP REGISTERS. * THE ROUTINE IS FORTRAN CALLABLE AS: * * CALL PACK(#WORDS,MAP,INPUT BUFFER,OUTPUT BUFFER) * * MAP = 0 MAPS * MAP >= 1 CRASHED SYSTEM * * THE OUTPUT BUFFER MUST BE 36 WORDS LONG * * * KOUNT NOP MAP NOP INBUF NOP ASSLC NOP PACK NOP JSB .ENTR GET THE PARAMETER ADDRESSES DEF KOUNT * LDA KOUNT,I GET THE # OF WORDS TO CONVERT BACK CMA,INA MAKE NEG AND SSA,RSS IF 0 OR NEG WORDS INPUT THEN FORGET IT JMP PACK,I STA KOUNT NOW SAVE FOR LOOP * ADA D8 ADD 8 TO SEE IF INPUT # SSA,RSS GREATER THAN 8 JMP CONTU ALL IS WELL ! LDA D8 JMP BACK * * CONTU LDA MAP,I GET THE MAP AND SAVE STA MAP FOR LATER * SZA,RSS SYS OR MAPS? JMP NOID MAPS OK AS IS LDA INBUF,I SYS NEED TO TAKE CARE OF STA INBUF INDIRECTION * NOID LDA ASSLC GET THE ADDRESS LDB ASSLC TWICE STB TEMP SAVE TEMPORARIALLY INA BUMP IT CLE,ELA CONVERT TO A BYTE ADDRESS STA ASSLC AND SAVE FOR LATER ADB D29 NOW DEFINE THE ASCII ADDRESS STB OABUF AND SAVE FOR THE IASCI SUBROUTINE STB YTEMP * LDA DM37 NOW CLEAR OUT THE OLD BUFFER STA XTEMP LDB BLANK GET A BLANK READY * LOOPX STB TEMP,I SET A BLANK INTO THE OUTPUT BUFFER ISZ TEMP STEP BUFFER POINTER ISZ XTEMP DONE YET ? JMP LOOPX NO * * * LOOP LDA MAP CRASHED SYS OR MAPS? SZA,RSS MAPS? JMP MAPPP YES * JSB IGET NO DEF *+2 GET THE INFO FROM THE DEF INBUF CRASHED FILE LDB A JMP OUT * MAPPP LDB INBUF,I GET THE INFO FROM THE MAP OUT STB XTEMP SAVE FOR THE IASCI SUBROUTINE JSB ASCI AND CONVERT TO OCTAL ASCII * JSB IASCI AND PLACE THROUGH THE ASCII FILTER DEF *+3 DEF XTEMP DEF TEMP * STB OABUF,I PUT RESULT INTO THE OUTPUT BUFFER * ISZ INBUF BUMP OUR ISZ OABUF POINTERS ISZ ASSLC AND THE CHAR ADDRESS * ISZ KOUNT ARE WE DONE ? JMP LOOP NOT YET * CCB YES,GET THE END OF THE OCTAL #'S ADB YTEMP LDA B,I NOW GET THE LAST WORD IOR ASTRK PUT IN AN ASTRISK STA B,I NOW PUT IT BACK * JMP PACK,I RETURN TO THE CALLER * * * * ** DATA TO OCTAL ASCII CONVERSION ** SPC 1 * CALLING SEQUENCE: LDB (DATA WORD) * LDA (ADDRESS AT START OF STORAGE) * JSB ASCI SPC 1 ASCI NOP OUTPUT 6 DIGITS * STA ASSLC SET THE ADDRESS (NOT USED AT THE MOMENT ) LDA KM6 GET NO. OF DIGITS TO CONVERT RBL MOVE FIRST DIGIT TO LOW B JSB NUM.F CONVERT THE NUMBER JMP ASCI,I RETURN SPC 2 *SCI2 NOP 5 DIGITS & BLANK * LDA KM5 GET NO OF DIGITS TO CONVERT * BLF POSITION FIRST DIGIT * JSB NUM.F CONVERT THE NUMBER * JMP ASCI2,I RETURN * * *********************************** * * CONVERT DIGITS TO ASCII BASE 8 * * *********************************** * * NUM.F NOP STA T1NUM SAVE THE DIGIT COUNT CPA KM6 IF 6 THEN CLA,INA,RSS USE 1 AS A MASK FOR FIRST DIGIT NUM00 LDA K7 ELSE USE 7 AND B ISOLATE THE DIGIT ADA "0" ADD 60 TO MAKE ASCII JSB PUT.F PUT IN THE BUFFER BLF,RBR POSITION THE NEXT DIGIT ISZ T1NUM DONE? JMP NUM00 NO DO NEXT DIGIT * JMP NUM.F,I YES RETURN * T1NUM NOP KM6 DEC -6 * SPC 2 * * ******************************** * * PUT CHARACTER IN LIST BUFFER * * ******************************** * PUT.F NOP STB T1PUT SAVE B LDB ASSLC GET CURRENT BUFFER ADDRESS AND B177 ISOLATE THE CHARACTER CLE,ERB WORD ADDRESS TO B E=UPPER,LOWER FLAG SEZ,RSS IF UPPER CHAR ALF,SLA,ALF POSITION AND SKIP XOR B,I INCLUSION OF HIGHER CHAR. XOR B40 ADD,TAKE AWAY LOWER BLANK STA B,I SET THE WORD DOWN ISZ ASSLC STEP THE CHAR ADDRESS LDB T1PUT RESTORE B JMP PUT.F,I RETURN * T1PUT NOP OABUF NOP B40 OCT 40 K7 DEC 7 D8 DEC 8 "0" OCT 60 D29 DEC 29 DM37 DEC -37 BLANK ASC 1, ASTRK OCT 52 LOWER BYTE = * B177 OCT 177 TEMP NOP D64 DEC 64 D1024 DEC 1024 XTEMP NOP YTEMP NOP ADDRS NOP PONTR NOP DUMMY NOP THIS IS A DUMMY SUBROUTINE TO FIX UP A POINTER JSB .ENTR SO THAT THE PACK ROUTINE CAN WORK WITH ARRAYS DEF ADDRS IN A PROGRAM AS WELL AS MEMORY ADDRESSES. * LDA ADDRS STA PONTR,I JMP DUMMY,I SPC 1 * * * * * * * THE IASCI SUBROUTINE TAKES ONE WORD OF INPUT AND CONVERTS THAT * WORD TO ASCII. IF ANY BYTE CAN NOT BE CONVERTED TO ASCII THEN * AN ASCII BLANK IS RETURNED FOR THAT BYTE. * * * CALLING SEQUENCE : JSB IASCI * DEF RETURN * DEF VALUE VALUE TO BE CONVERTED * DEF ASCII RETURNED ASCII VALUE * ---- * * ON RETURN, THE B REGISTER HAS THE ASCII VALUE * VALUE NOP LOCTN NOP IASCI NOP JSB .ENTR DEF VALUE * LDA VALUE,I GET THE VALUE TO CONVERT STA TEMP1 SAVE IT AND M377 KEEP ONLY LOWER BYTE JSB CNVRT AND CONVERT STB VALUE SAVE THE RETURNED VALUE * LDA TEMP1 GET THE WORD BACK AGAIN AND M1774 KEEP ONLY THE UPPER BYTE ALF,ALF SHIFT TO LOW ORDER JSB CNVRT AND GO CONVERT BLF,BLF PUT INTO UPPER BYTE ADB VALUE NOW MERGE ADD IN LOWER BYTE STB LOCTN,I AND RETURN IT TO THE USER JMP IASCI,I * * * THIS SUBROUTINE CONVERTS LOWER BYTE OF A TO ASCII AND PLACES * THE RETURNED ASCII INTO B * CNVRT NOP STA B AND SAVE CMA,INA ADA B135 SSA IS IT OK JMP BLNK2 NO LDA B40 CMA,INA ADA B SSA OK ? BLNK2 LDB B40 NO JMP CNVRT,I * * * * A EQU 0 B EQU 1 M1774 OCT 177400 B135 OCT 137 M377 OCT 377 TEMP1 NOP DM64 DEC -64 SIGN OCT 100000 * * * ************************************** * * MAP IN ANY PAGE OF PHYSICAL MEMORY * * ************************************** * * * THE PURPOSE OF THIS SUBROUTINE IS TO MAP IN THE PAGE REQUESTED * AND READ 64 WORDS OF THAT MAPPED PAGE. THE ROUTINE IS FORTRAN * CALLABLE. TO BE USED ONE OF TWO CONDITIONS MUST BE MET. * THE PROGRAM USING THE ROUTINE MUST NOT BE GREATER THAN 30K * IN LENGTH (IE IF PROGRAM IS 10K AND LARGEST ADDRESSABLE * PARTITION IS 12K YOUR OK. IF LARGEST ADDRESSABLE PARTITION IS * 11K YOU HAVE PROBLEMS). ALTERNATELY IF THE PROGRAM EXTENDS * INTO THE LAST TWO PAGES OF MEMORY MAKE SURE THIS ROUTINE * AND THE INPUT PARAMETERS TO THIS ROUTINE DO NOT RESIDE THERE * AND YOU WILL BE ALLRIGHT. * * THE PROGRAM MODIFIES THE USER MAP REGISTERS BUT ALSO RESTORES THEM. * * * CALLING SEQUENCE JSB MAPXX * DEF RETURN * DEF PAGE# PHYSICAL PG # (0-1023) * DEF OFFSET (NOT GREATER THAN 1023 DECIMAL) * DEF ARRAY (ARRAY OF 64 WORDS) * DEF FLAG 1/2/3 READ/WRITE/READ BUT DON'T * UPDATE PAGE# OR OFFSET * DEF NVAL NEW VALUE (FLAG = 2) * * * PAGE# NOP OFSET NOP ARRAY NOP FLAG NOP NVAL NOP * MAPXX NOP JSB $LIBR NOP JSB .ENTP DEF PAGE# * LDA MPBUF GET THE ADDRESS OF THE MAP BUFFER ADA SIGN SET THE SIGN BIT SO IT IS A READ USA GET THE USER MAP * LDA MAP31 GET THE OLD VALUE STA OLD31 AND SAVE IT LDA MAP32 OLD VALUE. STA OLD32 SAVE THIS TOO LDB PAGE#,I GET THE DESIRED PAGE STB MAP31 PUT IT INTO THE OLD PAGE INB BUMP PAGE # TO ACCOUNT FOR OVERFLOW STB MAP32 SET NEXT PAGE INTO THE LAST LOCATION * LDA MPBUF GET THE USER MAP BUFFER ADDRESS USA !!!!!! LOAD THE USER MAP !!!!!! * LDA FLAG,I GET THE READ WRITE FLAG CPA D2 ARE WE READING OR WRITING ? JMP WRTPG WRITING ! * * * * LDA DM64 GET LOOP INDEX STA XTEMP LDA START GET THE START ADDRESS ADA OFSET,I ADD IN THE OFFSET STA YTEMP SAVE POINTER LDA ARRAY GET ARRAY ADDRESS MLOOP LDB YTEMP,I GET THE WORD STB A,I AND PUT INTO BUFFER ISZ YTEMP BUMP OUR INA POINTERS ISZ XTEMP DONE ? JMP MLOOP NO * * RTMAP LDA OLD31 YES RESTORE THE USER MAP STA MAP31 LDA OLD32 STA MAP32 * LDA MPBUF GET THE ADDRESS USA !!!!!!!!!!RESTORE THE USER MAP!!!!!!!!!!!!!!!! JSB $LIBX RESTORE INTERUPTS DEF *+1 DEF *+1 * LDA FLAG,I GET THE FLAG CPA D1 DO WE UPDATE THE PAGE # & OFFSET RSS YES JMP MAPXX,I NO, SO RETURN TO THE CALLER * LDA OFSET,I GET THE OFFSET ADA D64 ADD 64 WORDS FOR WHAT WE JUST DID CLB DIV D1024 DIVIDE NEW OFFSET BY # OF WORDS IN PAGE ADA PAGE#,I ADD OLD PAGE # TO GIVE NEW PAGE # STA PAGE#,I AND SEND THE RESULT BACK STB OFSET,I SEND THE NEW OFFSET BACK TOO * JMP MAPXX,I RETURN TO CALLER * * WRTPG LDA START GET THE START ADDRESS ADA OFSET,I ADD THE OFFSET INTO THE PAGE LDB NVAL,I GET THE NEW VALUE STB A,I AND SET IT UP. JMP RTMAP RESET THE MAP & RETURN * * * D1 DEC 1 D2 DEC 2 START OCT 74000 START ADDRESS OF NEWLY MAPPED AREA MPBUF DEF MAPIT MAPIT BSS 30 BUFFER FOR 1ST 30 WORDS OF USER MAP MAP31 NOP THIS LOCATION IS USED TO CHANGE MAP MAP32 NOP THIS LOCATION IS FOR I/O OVERFLOW OLD31 NOP OLD32 NOP * * END ASMB,Q,C NAM ARTNS,7 ASSEMBLER ROUTINES FOR CDA4 ENT .XLA,.XLB,.MWF ENT JFTIM TIME CONVERSION ROUTINE ENT CDA3 COMMON AREA ENT PRNT PRINT ROUTINE ENT JMP FOR EXECUTING CODE FRAGMENTS ENT JMPX FUNCTION VERSION OF JMP ENT JRETN RETURN POINT FOR JMP/JMPX EXT EXEC,IGET,.ENTR,CDA * * THIS ROUTINE DOES XLA,XLB AND MWF FROM THE DUMP * FILE (VIA IGET). IT IS A DIRECT REPLACEMENT * FOR THE NAMED INSTRUCTIONS. * .XLA NOP STA ASAV SAVE THE A REG ELA AND THE STA ESAV REG LDA .XLA,I GET THE ADDRESS CPA AIND IS IT A INDIRECT? JMP CALL YES WE ARE OK ALREADY * IND RAL,CLE,SLA,ERA NO TRACK DOWN ANY INDIRECTS LDA A,I SSA MORE? JMP IND YES (NOTE B MUST BE LOADED FOR THIS * STA ASAV SAVE THE ADDRESS OF INTEREST CALL STB BSAV SAVE THE B REG JSB IGET GET THE WORD DEF *+2 DEF ASAV LDB ESAV RESTORE THE E ERB REG. AND LDB BSAV THE B REG. ISZ .XLA STEP TO THE RETURN JMP .XLA,I AND DO SO * ASAV NOP BSAV NOP ESAV NOP AIND DEF A,I * * .XLB NOP HERE WE DO THE XLB INSTRUCTION STA ASAV2 SAVE A LDA .XLB,I GET THE TARGET ADDRESS STA XLAAD AND SET FOR CALL LDA ASAV2 RESTORE A IN CASE IT IS ADDRESS JSB .XLA DO THE LOAD TO A XLAAD NOP LDB A GET THE RESULT TO B AS REQUIRED LDA ASAV2 RESTORE A ISZ .XLB STEP TO THE RETURN JMP .XLB,I AND DO SO * * ASAV2 NOP * .MWF NOP MOVE WORDS FROM X=COUNT,B=TO,A=FROM STA ASAV SAVE A TEMP ELA NOW GET E STA ESAV AND SAVE IT LDA ASAV RESTORE A RAL,CLE,SLA,ERA WE ONLY DO ONE LEVEL OF INDIRECT LDA A,I RBL,CLE,SLB,ERB LDB B,I DST FROM CXA GET THE COUNT TO A CMA,INA SET NEGATIVE STA COUNT AND SET IT UP NEXT JSB IGET NOW DO IT DEF *+2 DEF FROM STA TO,I SET THE WORD ISZ FROM ISZ TO ISZ COUNT DONE? JMP NEXT NO DO THE NEXT ONE * LDA ESAV GET THE E REG BACK ERA DLD FROM RESTORE A,B AS REQUIRED JMP .MWF,I AND RETURN * FROM NOP TO NOP COUNT NOP * * * DRTN IS USED TO MAKE SEGMENT CALLS LOOK LIKE * SUBROUTINE CALLS FROM FORTRAN * ENT DRTN DRTN DEF *-* ENTRY POINT ISZ DRTN BUMP RETURN ADDRESS ISZ DRTN AGAIN LDA DRTN LOAD RETURN ADDRESS AS RETURN VALUE JMP DRTN,I RETURN * * * HED TIME FORMAT SUBROUTINE (FOR CDA4) * NAME: JFTIM * SOURCE: 92067-18082 * RELPC: 92067-16035 * PGMR: G.A.A.,C.M.M.,(J.E.F.) * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * CALLING SEQUENCE: * *C GET THE TIME IN A 15 WORD STRING * DIMENSION IBUF(15) *C PARAMETERS ARE SET UP IN CDA3 NAMED COMMON AREA * CALL JFTIM(IBUF) * * * THE TIME AND DATE TO BE CONVERTED ARE STORED IN /CDA3/ * SUP * * GET TIME AND BUILD HEADER MESSAGE * A EQU 0 B EQU 1 O13 OCT 13 N1900 DEC -1900 D12 DEC 12 MD60 DEC -60 DM12 DEC -12 O30K OCT 30000 ASCII 0 IN HIGH WORD M1 OCT -1 "AM" ASC 1,AM "PM" ASC 1,PM O3 OCT 3 * * P1 NOP JFTIM NOP DLD JFTIM,I STA JFTIM RSS INDCT LDB B,I TRACK DOWN INDIRECTS RBL,CLE,SLB,ERB JMP INDCT STB P1 * * JSB EXEC * DEF *+4 * PARMS * DEF O13 * HAVE BEEN * DEF ITIME * PASSED * DEF IYEAR * THROUGH COMMON LDA IMIN JSB PD00 LDB ":" IOR O30K DON'T SUPPRESS LEADING ZEROS HERE RRR 8 B=1'S BLANK,A= ":" , 10'S DST TMSG+1 SET IN MESSAGE LDA IHOUR LDB "PM" ASSUME PM FOR NOW ADA DM12 IS IT SSA,RSS TEST AND ADJUST JMP PM YES * LDB "AM" NO USE AM LDA IHOUR RESTORE THE CORRECT HOUR PM SZA,RSS IF ZERO USE LDA D12 TWELVE STB TMSG+3 SET THE AM PM JSB PD00 STA TMSG HOURS * LDA IYEAR ADA N1900 SUBTRACT THE HUNDREDS JSB PD00 CONVERT THE YEAR STA TMSG+14 YEARS LDB IDAY ADB MD60 -60 LDA IYEAR AND O3 SZA SKIP IF LEAP YEAR SSB ADB M1 ADJUST FOR LEAP YEAR SSB ADB D366 ADB D31 LDA B RAL,RAL ADA B *5 CLB DIV D153 STA ITIME QUOTIENT=MONTH. LDA B CLB DIV O5 INA GET DAY OF MONTH. JSB PD00 STA TMSG+8 LDB ITIME RECOVER MONTH BLS ADB MOTBA DLD B,I DST TMSG+10 CCA CALCULATE DAY OF WEEK. ADA IYEAR ARS,ARS ADA IYEAR ADA IDAY CLB DIV O7 BLS ADB DAYWK DLD B,I DST TMSG+5 LDB DM15 SET WORD COUNT STB CNT LDA TMSGA AND THE TIME ARRAY OLOOP LDB A,I MOVE IT STB P1,I INA ISZ P1 ISZ CNT JMP OLOOP * JMP JFTIM,I RETURN * * * PD00 NOP CONVERT TO 2 ASCII DIGITS CLB DIV D10 DIVIDE BY 10 A=HIGH ,B=LOW SZA SUPPRESS ADA "0" LEADING ZEROS ALF,ALF PUT HIGH TO HIGH ADA B ADD IN THE LOW IOR "0" ADD ASCII BLANK 0 JMP PD00,I RETURN * "0" ASC 1, 0 ":" ASC 1, : D10 DEC 10 DM15 DEC -15 CNT BSS 1 O5 OCT 5 O7 OCT 7 D31 DEC 31 D100 DEC 100 D153 DEC 153 D366 DEC 366 * SPC 1 * CDA3 EQU * COMMON AREA FOR PASSING IN TIME ITIME NOP TENS OF MSEC NOP SEC IMIN NOP MIN IHOUR NOP IDAY NOP IYEAR NOP * SPC 1 * MESSAGE FORMAT: ASC 15,10:03 AM MON., 29 DEC., 1975 * 001122334455667788990011223344 * TMSGA DEF *+1 TMSG ASC 15,12:01 PM MON., 29 DEC., 1975 * DAYWK DEF *+1 ASC 14,FRI.SAT.SUN.MON.TUE.WED.THU. * MOTBA DEF *-1 ASC 2,MAR. ASC 6,APR.MAY JUNE ASC 6,JULYAUG.SEPT ASC 6,OCT.NOV.DEC. ASC 4,JAN.FEB. * * * * PRNT ROUTINE - PRINTS THE STRING PASSED ON UNIT * LU2 (AS DEFINED IN COMMON AREA CDA). THE LENGTH * IS IN THE FIRST WORD IN ASCII; THE MESSAGE FOLLOWS. * FORTRAN CALL: CALL PRNT(10H05MESSAGE ) * PARG DEF *-* ARGUMENT - ADDR OF DATA PRNT NOP JSB .ENTR RESOLVE EXTERNALS DEF PARG LDA PARG,I GET FIRST WORD OF ARG (IE LENGTH IN ASCII) ISZ PARG BUMP TO DATA ADDR ADA NA00 ADD (- 2H00) TO GET TWO BINARY DIGITS CLB SPLIT RRR 8 THE DIGITS STA TEMP MULTIPLY ALS,ALS A ADA TEMP BY ALS 10 RBR,RBR SHIFT RBR,RBR B RBR,RBR RIGHT RBR,RBR EIGHT AND ADA B ADD IN LOW DIGIT ADA N1 DECREMENT AND STA PCNT SAVE LENGTH JSB EXEC NOW PRINT DEF *+5 DEF D2 DEF CDA+1 DEF PARG,I DEF PCNT JMP PRNT,I RETURN N1 DEC -1 PCNT DEF *-* NUMBER OF WORDS TO PRINT TEMP DEF *-* TEMP NA00 OCT 147720 (- 2H00) -- FOR STRIPPING ASCII D2 DEC 2 * * * JMPX SUBROUTINE - DOES A JMP TO THE ADDRESS GIVEN; * RETURNS A VALUE IN THE A REGISTER * CALL: RESULT = JMPX (ADDR, ARG) * * JADR DEF *-* ADDR TO JUMP TO JARG DEF *-* ARGUMENT JMPX NOP ENTRY POINT JSB .ENTR FETCH ARGS DEF JADR LDB JARG LOAD ARG STB MADDR SAVE LDA JADR,I JMP A,I BRANCH TO ROUTINE JRETN LDA MADDR LOAD RETURN VALUE JMP JMPX,I RETURN POINT * * * JMP SUBROUTINE - DOES A JMP TO THE ADDRESS * SPECIFIED. FORTRAN CALL: CALL JMP(ADDR) * JMP EQU JMPX MADDR DEF *-* RETURN ADDRESS FOR JMP/JMPX END ASMB,R,L HED QTAB - DATA FOR HELP FUNCTION NAM QTAB,7 ENT QT * ******************************************************************** * * QT IS A DATA TABLE FOR USE BY THE HELP FUNCTION OF CDA4. * THE FORMAT IS DESCRIBED IN QUSUB, BUT CAN EASILY BE INDUCED * FROM THE CODE BELOW. * * NOTE THAT THE FIRST TWO LETTERS OF THE LABELS USED FOR EACH * TWO WORD ENTRY ARE THE SAME AS THE COMMAND CODE. --DSC IS * THE LABEL FOR THE ONE LINE DESCRIPTION; --DTL IS THE LABEL * FOR THE DETAILED DESCRIPTION. * ******************************************************************** * SUP SUPRESS WORDS 2-N FOR EACH LINE * * QT EQU * DEF ANDSC ANALYZE SYSTEM DEF ANDTL DEF BPDSC SET BASE PAGE DEF BPDTL DEF CMDSC COMPARE MEMORY DEF CMDTL DEF CTDSC COMPARE TABLES DEF CTDTL DEF DBDSC DEBUG DEF DBDTL DEF DPDSC DISPLAY & ARITH DEF DPDTL DEF DRDSC DEV REF TABLE DEF DRDTL DEF DUDSC DUMP SYS DEF DUDTL DEF /EDSC EXIT DEF /EDTL DEF EQDSC EQT TABLE DEF EQDTL DEF EPDSC EJECT PAGE DEF EPDTL DEF F/DSC FIND VAL IN MEM DEF F/DTL DEF FIDSC SPECIFY CRASH FILE DEF FIDTL DEF IDDSC ID TABLE DEF IDDTL DEF INDSC INT TABLE DEF INDTL DEF LIDSC LIST ENTRY POINT DEF LIDTL DEF LLDSC CHANGE LIST DEF LLDTL DEF LMDSC LIST MEM DEF LMDTL DEF MADSC DUMP MAPS DEF MADTL DEF MPDSC SET MAP DEF MPDTL DEF TADSC TRACK ASSSIGNMENT DEF TADTL DEF TRDSC TRACE LIST DEF TRDTL DEF VEDSC VERIFY ID TABLE DEF VEDTL DEF WHDSC WHZAT DEF WHDTL DEF XXDSC '**' - ANNOTATE LISTING DEF XXDTL DEF PKDSC PACK OPTION DEF PKDTL DEF ??DSC HELP DEF ??DTL DEF 0 END OF TABLE * * ONE-LINE DESCRIPTIONS * IDDSC ASC 11,11ID LIST ID SEGMENT EQDSC ASC 13,13EQ LIST EQT AND EXTENTS DRDSC ASC 12,12DR LIST DEV REF TABLE LMDSC ASC 09,09LM LIST MEMORY INDSC ASC 13,13IN LIST INTERRUPT TABLE TADSC ASC 17,17TA LIST TRACK ASSIGNMENT TABLE TRDSC ASC 08,08TR TRACE LIST DPDSC ASC 20,29DP DISPLAY INPUT IN OCTAL, DECIMAL & ASC 09,ASCII (& DO ARITH) LLDSC ASC 12,12LL CHANGE LIST DEVICE F/DSC ASC 14,14F/ FIND A VALUE IN MEMORY LIDSC ASC 11,11LI LIST ENTRY POINT FIDSC ASC 17,17FI SPECIFY CRASHED SYSTEM FILE CMDSC ASC 16,16CM COMPARE CRASH TO SNAPSHOT BPDSC ASC 20,20BP SET BASE PAGE SUBSTITUTION ON/OFF CTDSC ASC 20,24CT COMPARE PARTICULAR WORDS OF TABLES ASC 04, TO SNAP MPDSC ASC 08,08MP SELECT MAP /EDSC ASC 13,13/E (OR EN OR EX) EXIT XXDSC ASC 11,11** ANNOTATE LISTING PKDSC ASC 18,18PK PACKED OPTION (NOT A COMMAND) ??DSC ASC 18,18?? HELP FEATURE - TRY ??,COMMAND WHDSC ASC 12,12WH RUN WHZAT ON CRASH * * THOSE DESCRIPTIONS THAT ARE THE SAME AS THE DETAILS * ARE EQUATED AFTER ALL OF THE DETAILED DESCRIPTIONS * * DETAILED DESCRIPTIONS * IDDTL ASC 09,09ID,PROGRAM NAME ASC 09,09ID,SEGMENT NAME ASC 16,16ID,NUMBER = ALL ID'S IN SYSTEM DEF 0 END OF DESC * EQDTL ASC 04,04EQ,NUM ASC 18,18EQ,NUM,NUM GIVES INCLUSIVE EQT'S DEF 0 END OF DESC * LMDTL ASC 10,10LM,ADDR,# OF WORDS ASC 05,05LM,ADDR ASC 19,19LM,ADDR,-ADDR GIVES INCLUSIVE ADDRS DEF 0 END OF DESC * DRDTL ASC 04,04DR,NUM ASC 18,18DR,NUM,NUM GIVES INCLUSIVE DRT'S DEF 0 END OF DESC * INDTL ASC 04,04IN,NUM ASC 19,19IN,NUM,NUM GIVES INCLUSIVE INT ENTS DEF 0 END OF DESC * LLDTL ASC 07,07LL,LIST LU # DEF 0 END OF DESC * F/DTL ASC 20,25F/,VALUE TO FIND,START ADDRESS,# WORDS ASC 05, TO SEARCH ASC 19,19F/,VALUE,STARTING ADDR,-ENDING ADDR DEF 0 END OF DESC * LIDTL ASC 16,16LI,ENTRY POINT NAME,# OF WORDS DEF 0 END OF DESC * TADTL ASC 02,02TA ASC 05,05TA,LU # ASC 13,13TA,LU #,TRK #,# OF TRKS DEF 0 END OF DESC * /EDTL ASC 04,04/E OR ASC 04,04EX OR ASC 11,11EN -- ALL EXIT CDA4 DEF 0 END OF DESC * DPDTL ASC 19,19DP,VALUE,OP,VALUE OP IS +,-,*, OR / DEF 0 END OF DESC * TRDTL ASC 20,33TR,START ADDR,LIST DELIMITER [,OFFSET ASC 13,[,MAX # LINKS TO FOLLOW]] DEF 0 END OF DESC * FIDTL ASC 05,05FI,NAMR DEF 0 END OF DESC * CMDTL ASC 20,20CM,ADDR,-ADDR COMPARE BETWEEN LIMITS ASC 09,09CM,ADDR,# WORDS DEF 0 END OF DESC * BPDTL ASC 14,14BP,XX XX IS 'ON' OR 'OFF' DEF 0 END OF DESC * CTDTL ASC 18,18CT COMPARE ALL TABLES ASC 17,17CT,XX COMPARE TABLE XX ASC 19,19CT,?? PRINT LIST OF TABLES ASC 20,23CT,XX,ENTRY # COMPARE SINGLE ENTRY OF ASC 03, TABLE DEF 0 END OF DESC * MPDTL ASC 20,20MP,XX XX IS 'PH', 'DP', 'SY', OR 'US' DEF 0 END OF DESC * XXDTL ASC 18,18**,TEXT TREATED AS COMMENT DEF 0 END OF DESC * PKDTL ASC 20,21--PK,... GIVES -- IN PACKED FORM ASC 01,AT DEF 0 END OF DESC * ??DTL ASC 20,20??,-- DESCRIBES -- IN DETAIL DEF 0 END OF DESC * DUDTL ASC 09,09DU DUMP SYSTEM DEF 0 END OF DESC * ANDTL ASC 12,12AN ANALYSIS OF SYSTEM DEF 0 END OF DESC * MADTL ASC 12,12MA DUMP THE FOUR MAPS DEF 0 END OF DESC * EPDTL ASC 16,16EP EJECT PAGE IF LINE PRINTER DEF 0 END OF DESC * DBDTL ASC 11,11DB ENTER DEBUG MODE DEF 0 END OF DESC * WHDTL ASC 04,04WH,AL ASC 04,04WH,SM ASC 04,04WH,PA DEF 0 END OF DESC * VEDTL ASC 13,13VE VERIFY THE ID TABLE DEF 0 END OF DESC * * EQUATES FOR DESCRIPTIONS THAT ARE THE SAME AS THE DETAILS * DUDSC EQU DUDTL ANDSC EQU ANDTL MADSC EQU MADTL EPDSC EQU EPDTL VEDSC EQU VEDTL DBDSC EQU DBDTL * * END FTN4,L PROGRAM CDA4A(5),24999-16197 REV.2024 IMPLICIT INTEGER (A-Z) COMMON /CDA/LU1, LU2, BPFLAG, MPFLAG, IOREC, SOREC, IERR, IWRN, & HIDEBP, HIDEMP, FIOPEN, INTER, IDCB(144), SDCB1(144), & SDCB2(144), IBUF(128), SBUF1(128), SBUF2(128), TRTAB(64) C COMMON /CDASG/ RTNA, IPBUF(33), IPRAM(6), IARRAY(64), IDISC(36), & IGO(35), IGO2(35), IFILE(10), JBUF(30), IOP, LEN C EQUIVALENCE (IPBUF(2),IPRS1),(IPBUF(6),IPRS2),(IPBUF(10),IPRS3), & (IPBUF(14), IPRS4), (IPBUF(18), IPRS5), (IPBUF(22), IPRS6), & (IPBUF(26), IPRS7), (IPBUF(30), IPRS8) C C THIS SEGMENT HANDLES SOME OF THE COMMANDS FOR CDA4 C C SELECT THE APPROPRIATE SUBROUTINE: C IF(IOP.NE.0) GO TO 10 CALL INIT GO TO 1 C 10 GO TO (100, 100, 100, 100, 100, 100, 100, 100, 100, 100, & 100, 100, 113, 114, 115, 116, 117, 118, 119, 100, & 121, 122, 123, 100, 100, 100, 127, 100, 129, 100, & 100, 100, 100, 100, 100) IOP C 100 CALL PRNT(16H08INTERNAL ERROR) GO TO 1 C 113 CALL IDSUB(IPBUF, IFILE, SDCB1, IPRAM, LU2, LU1) GO TO 1 114 CALL EQSUB(IBUF, IPRS2, IPRS3, IPRAM, LU2, LU1) GO TO 1 115 CALL DRSUB(IPRS2, IPRS3, IPRAM, LU2) GO TO 1 116 CALL INSUB(IPRS2, IPRS3, IPRAM, LU2, LU1) GO TO 1 117 CALL CTSUB(IPRS2, IPRS3) GO TO 1 118 CALL FSSUB(IPRS2, IPRS3, IPRS4, IPRAM, LU2, LU1) GO TO 1 119 CALL LISUB(IDISC, IFILE, IPRS2, SDCB1, IPRAM, LU2, LU1, IPRS3) GO TO 1 121 CALL TASUB(IPRS2, IPRS3, IPRS4, IPRAM, LU2, LU1) GO TO 1 122 CALL CMSUB(IPRS2, IPRS3) GO TO 1 123 CALL MASUB(IARRAY) GO TO 1 127 CALL ANSUB(IDISC, IFILE, IBUF, IPBUF, SDCB1, IPRAM, LU2, LU1) GO TO 1 129 CALL PRNT(10H05NOT YET ) GO TO 1 C C NOW RETURN TO MAIN C 1 CALL JMP(RTNA) END END$ FTN4,Q,L SUBROUTINE CMSUB(L1,LEN) IMPLICIT INTEGER (A-Z) COMMON /CDA/ LU1, LU2, BPFLAG, MPFLAG, IOREC, SOREC, IERR, IWRN, & HIDEBP, HIDEMP, FIOPEN, INTER, IDCB(144), SDCB1(144), & SDCB2(144), IBUF(128), SBUF1(128), SBUF2(128), TRTAB(64), & PRFLAG DIMENSION OBUF(72) C C SUBROUTINE TO IMPLEMENT THE CM (COMPARE MEMORY) COMMAND C C------------------------------------------------------------------------ C C COMPUTE COMPARISON LIMITS 10 L2 = L1 + LEN IF (LEN.LT.0) L2 = -LEN L1 = (L1/8)*8 IF(L1.GE.0.AND.L2.GE.0) GO TO 15 CALL PRNT(28H14NEGATIVE ADDRESSES ILLEGAL) RETURN 15 DO 60 IADDR = L1,L2,8 COMP = 0 DO 20 J = 1,72 OBUF(J) = 2H 20 CONTINUE C C LOOK FOR DIFFERENCES; IF ANY ARE FOUND, CONVERT THEM TO OCTAL C DO 30 J = 0,7 IF (SGET(IADDR+J).EQ.IGET(IADDR+J))GO TO 30 CALL OCT(SGET(IADDR+J),OBUF(J*4+41)) COMP = 1 30 CONTINUE C C IF A DIFFERENCE WAS FOUND IN THIS LINE, FORMAT THE FIRST LINE C AND PRINT BOTH LINES C IF(COMP.EQ.0)GO TO 60 DO 40 J = 0,7 CALL OCT(IGET(IADDR+J),OBUF(J*4+5)) 40 CONTINUE 50 CALL OCT(IADDR,OBUF) CALL EXEC(2,LU2,OBUF,36) CALL EXEC(2,LU2,OBUF(37),36) CALL PRNT(4H02 ) IF(IFBRK(IDMY).LT.0) RETURN 60 CONTINUE RETURN END C C C **********GET ID SEGMENT INFO************** C C SUBROUTINE IDSUB(IPBUF,IFILE,IDCB,IPRAM,LU2,LU1) DIMENSION IPBUF(33),IPRAM(6),IMESS1(9),IEXT(4) DIMENSION IFILE(10),IDCB(144),IDEX(3),IBMES(11) DIMENSION ISBID(9),ILBID(9) DATA IMESS1/2H ,2HID,2H S,2HEG,2H O,2HF / DATA IEXT/2H ,2HEX,2HTE,2HNT/ DATA IDEX/2H$I,2HDE,2HX / DATA IBMES/2H ,2H ,2H ,2H ,2HVI,2HRG,2HIN,2H I,2HD , & 2HSE,2HGS/ DATA ISBID/2H ,2H/ DATA ILBID/2H ,2H / C C IBLNK = 0 C IBFLG -1/NOT BLANK 0/BLANK 1/VIRGIN IBFLG = -1 C IFRST 1 AFTER 1ST SHORT ID SEG REACHED IFRST = 0 KYWORD = IGET(1657B) -1 IF(IPBUF(5).EQ.1) GO TO 175 C C 150 DO 170 I = 1,257 KYWORD = KYWORD +1 IF(IGET(KYWORD).EQ.0) GO TO 190 IF(((IPBUF(6).EQ.IGET(IGET(KYWORD)+12)).AND. & (IPBUF(7).EQ.IGET(IGET(KYWORD)+13))).AND. & (IPBUF(8).EQ.IOR(IAND(IGET(IGET(KYWORD)+14),177400B),40B))) & GO TO 176 170 CONTINUE 175 KYWORD = KYWORD +1 IF(IPRAM(3).EQ.9999) RETURN C EOF SO PRINT VIRGIN SHORT ID MESSAGE IF(IGET(KYWORD).EQ.0) GO TO 186 IF(IGET(IGET(KYWORD)+12).NE.0) GO TO 176 IMESS1(7) = 2H IBFLG = 0 GO TO 180 176 IMESS1(7) = IGET(IGET(KYWORD)+12) IMESS1(8) = IGET(IGET(KYWORD)+13) IMESS1(9) = IGET(IGET(KYWORD)+14) C 180 ISTART = IGET(KYWORD) ISTOP = ISTART +32 ITEMP = IAND(IGET(IGET(KYWORD) +14),17B) ITEMP1= IAND(IGET(IGET(KYWORD) +14),20B) IF(ITEMP1.EQ.20B) ISTART= IGET(KYWORD) +11 C 1ST SHORT ID, GO PRINT VIRGIN LONG ID MESSAGE IF ((ITEMP1.EQ.20B).AND.(IFRST.EQ.0)) GO TO 186 C C 'ID' COMMAND, SO GIVE HIM THE ID SEGMENT !! C NOT A FREE ID 160 IF (IBFLG.EQ.-1) GO TO 183 C 1ST VIRGIN BLANK ID FOUND, JUST UP COUNT IF (IBFLG.EQ.1) GO TO 182 C ELSE CHECK IF 1ST VIRGIN BLANK ID DO 181 I = ISTART,ISTOP IF ((I.EQ.(ISTART+3)).AND.(IGET(I).EQ.20B)) GO TO 181 IF (IGET(I).NE.0) GO TO 183 181 CONTINUE IBFLG = 1 182 IBLNK = IBLNK + 1 GO TO 175 183 CALL EXEC (3,LU2+700B,1) CALL EXEC(2,LU2,IMESS1,-17) CALL DOIO(ISTART,ISTOP,LU2,IPRAM) C C IF NOT EMA OR IF IT'S A SEGMENT OR MEM RES C THEN DON'T PRINT THE ID EXTENSION C IF((ITEMP1 .EQ. 20B).OR. (ITEMP .EQ. 1)) GO TO 185 IF(IGET(IGET(KYWORD)+28).EQ.0) GO TO 185 C GET THE ID EXTENSION CALL FNDET(IDEX,IERR,IDCB,MYTYP,IWRD4) IF (IERR.NE.0) GO TO 187 IF (MYTYP.EQ.3) CALL NFSUB(IDEX,LU1) IF (MYTYP.EQ.3) GO TO 185 ISTART = IAND(IGET(IGET(KYWORD)+28),111111B) ISTART=IGET(IGET(IWRD4)+ISTART/1024) CALL EXEC(2,LU2,IEXT,4) CALL DOIO(ISTART,ISTART+2,LU2,IPRAM) 185 IF(IPBUF(5).EQ.1) GO TO 175 RETURN C C 186 IBFLG = -1 C EOF, NO ID'S OR NO VIRGIN SHORT ID'S IF ((IGET(KYWORD).EQ.0).AND.(IBLNK.EQ.0)) RETURN C NO VIRGIN LONG ID'S IF (IBLNK.EQ.0) GO TO 166 CALL EXEC (3,LU2+700B,1) CALL CNUMD(IBLNK,IBMES) CALL EXEC (2,LU2,IBMES,11) C SHORT AND EOF IF ((ITEMP1.EQ.20B).AND.(IGET(KYWORD).EQ.0)) &CALL EXEC(2,LU2,ISBID,9) C OR LONG IF (IFRST.EQ.0) CALL EXEC(2,LU2,ILBID,9) C EOF IF (IGET(KYWORD).EQ.0) RETURN IBLNK = 0 C 1ST PART (LONG ID'S DONE, IE REACHED 1ST SHORT ID) 166 IFRST = 1 GO TO 160 C C 187 CALL CNUMD(-(IERR),IFILE(8)) CALL EXEC (2,LU1,IFILE,10) GO TO 185 C C 190 CALL NFSUB(IPBUF(6),LU1) RETURN END C C C **********GET EQT INFO************* C C SUBROUTINE EQSUB(IBUF,IPRS2,IPRS3,IPRAM,LU2,LU1) DIMENSION IPRAM(6),IBUF(30),IMESS2(11) DATA IMESS2/2H ,2HEQ,2HT ,2H# ,2H ,2H ,2H ,2H ,2HDV,2HR / C C IEQTA = IGET(1650B) IEQTNO = IGET(1651B) IPRL2 = IPRS2 IPRL3 = IPRS3 IF(IPRS3 .GT. IEQTNO) IPRL3 = IEQTNO IF(IPRS2.GT.IEQTNO) GO TO 220 IF(IPRS2.LT. 1) IPRL2 = 1 C C DO 210 I = IPRL2,IPRL3 IF(IPRAM(3) .EQ. 9999) RETURN ISTART = IEQTA + (I - 1)*15 CALL CNUMD(I,IBUF(2)) IMESS2(4) = IBUF(4) IBUF = (IAND(IGET(ISTART+4),37400B)/256) IBUF = IBUF + 2*(IBUF/8) CALL CNUMD(IBUF,IBUF(2)) C INSERT A 0 SO DVR00 DOESNT LOOK LIKE DVR 0 IF (IAND(IBUF(4),177400B).EQ.20000B) IBUF(4) = IBUF(4) + 10000B IMESS2(11) = IBUF(4) C CALL EXEC(3,LU2+700B,1) CALL EXEC(2,LU2,IMESS2,11) CALL DOIO(ISTART,ISTART +14,LU2,IPRAM) 210 CONTINUE RETURN 220 CALL IWSUB(LU1) RETURN END C C C C **********GET DEVICE REF TABLE************** C SUBROUTINE DRSUB(IPRS2,IPRS3,IPRAM,LU2) DIMENSION IPRAM(6),IMESS3(6) DATA IMESS3/2H ,2HDR,2HT ,2HPA,2HRT,2H / C C IDRT = IGET(1652B) LUMAX = IGET(1653B) IPRL2 = IPRS2 IPRL3 = IPRS3 IMESS3(6) = 20061B C C CALL EXEC(2,LU2,IMESS3,6) IF(IPRS3.GT.LUMAX) IPRL3 = LUMAX IF(IPRS2.LE.0) IPRL2 = 1 IF (IPRS3.EQ.0) IPRL3 = IPRL2 CALL DOIO(IDRT + IPRL2-1,IDRT + IPRL3-1,LU2,IPRAM) IMESS3(6) = 20062B CALL EXEC(3,LU2+700B,1) CALL EXEC(2,LU2,IMESS3,6) CALL DOIO(IDRT+IPRL2-1+LUMAX,IDRT+IPRL3-1+LUMAX,LU2,IPRAM) RETURN END C C C *************GET THE INTERUPT TABLE***************** C C SUBROUTINE INSUB(IPRS2,IPRS3,IPRAM,LU2,LU1) DIMENSION IPRAM(6),IMESS5(6),IMESS8(11) DATA IMESS5/2H ,2HIN,2HT ,2HTA,2HBL,2HE / DATA IMESS8/2HIN,2HT ,2HTA,2HBL,2HE ,2HST,2HAR,2HTS, & 2H A,2HT ,2H6./ C C INTBA = IGET(1654B) INTLG = IGET(1655B) IPRL3 = IPRS3 C C IF(IPRS2.LT.6) GO TO 550 CALL EXEC(2,LU2,IMESS5,-12) IF(IPRS3.GT.INTLG) IPRL3 = INTLG IF (IPRS3.EQ.0) IPRL3 = IPRS2 ISTART = INTBA + IPRS2 -6 ISTOP = INTBA +IPRL3 -6 IPRAM = IPRS2 IPRAM(2) = 1 CALL DOIO(ISTART,ISTOP,LU2,IPRAM) RETURN 550 CALL EXEC(2,LU1,IMESS8,-22) RETURN END C C C*******FIND A WORD BETWEEN GIVEN LIMITS IN MEMORY******** C SUBROUTINE FSSUB(IPRS2,IPRS3,IPRS4,IPRAM,LU2,LU1) DIMENSION IPRAM(6),IDUM(3) DATA IDUM/2H ,2H ,2H / C C L1 = IPRS3 L2 = IPRS3 + IPRS4 - 1 IF (IPRS3.LT.0) GO TO 860 IF (IPRS4.LT.0) L2 = - IPRS4 DO 850 I = L1, L2 IF(IGET(I).EQ.IPRS2) GO TO 820 GO TO 850 820 CALL DOIO(I,I,LU2,IPRAM) IF(IPRAM(3).EQ.9999) RETURN IPRAM(3) = 1 IPRAM = IPRAM + 1 850 CONTINUE IF(IPRAM(3).EQ.0) CALL NFSUB(IDUM,LU1) RETURN 860 CALL ITSUB(LU1) RETURN END C C C*******FIND ADDRESS OF SELECTED SYSTEM ENTRY POINTS******** C C C C C C SUBROUTINE LISUB(IDISC,IFILE,IPRS2,IDCB,IPRAM,LU2,LU1, & IPRS3) DIMENSION IABS(7),IRP(6),LDISC(5),IDISC(36),IFILE(10) DIMENSION IDCB(144),IPRAM(6) DATA IABS/2H ,2HAB,2HS ,2H / DATA IRP/2H ,2HRP,2H / DATA LDISC/2H ,2HDI,2HSC,2H R,2HES/ C C IERR = 0 IPRL3 = IPRS3 IF (IPRS3.LE.0) IPRL3 = 1 C C FIND TYPE AND 4TH WORD INFO FOR SELECTED ENTRY POINT C BRANCH ACCORDINGLY C CALL FNDET(IPRS2,IERR,IDCB,MYTYP,IWRD4) IF (IERR.NE.0) GO TO 992 GO TO (975,980,995,985,990) MYTYP C C C MEMORY RESIDENT C C 975 CALL DOIO (IWRD4,IWRD4+IPRL3-1,LU2,IPRAM) RETURN C C C DISK RESIDENT C C 980 CALL EXEC (2,LU2,LDISC,5) IDISC(7) = 2H CALL CNUMD(IWRD4/128,IDISC(11)) CALL CNUMD(IAND(IWRD4,177B),IDISC(19)) CALL EXEC (2,LU2,IDISC(7),15) RETURN C C C ABSOLUTE C C 985 CALL CNUMO(IWRD4,IABS(5)) CALL EXEC (2,LU2,IABS,7) RETURN C C C RP MICRO CODED MACRO C C 990 CALL CNUMO(IWRD4,IRP(4)) CALL EXEC (2,LU2,IRP,6) RETURN C C C ERROR CONDITION C C 992 CALL CNUMD(-(IERR),IFILE(8)) CALL EXEC (2,LU1,IFILE,10) RETURN C C 995 CALL NFSUB(IPRS2,LU1) RETURN END C C C C*********** PRINT OUT THE TRACK ASSIGNMENT TABLE ****************** C SUBROUTINE TASUB(IPRS2,IPRS3,IPRS4,IPRAM,LU2,LU1) DIMENSION IAUX(5),ISYS(5),ITAT(12),IPRAM(6) DATA IAUX/2H ,2HAU,2HX ,2HDI,2HSC/ DATA ISYS/2H ,2HSY,2HS ,2HDI,2HSC/ DATA ITAT/2H ,2HTR,2HAC,2HK ,2HAS,2HSI,2HGN,2HME,2HNT, &2H T,2HAB,2HLE/ C C CALL EXEC(2,LU2,ITAT,12) IPRAM = 0 IPRL4 = IPRS4 IF (IPRS4.LE.0) IPRL4 = 1 IF((IPRS2.GT.3).OR.(IPRS2.LT.0)) GO TO 1530 C GET # OF TRACKS ON AUX DISC INEED =-( IGET(1755B))- IGET(1756B) C GET STOP ADDRESS OF TAT FOR SYS DISC ISTOP = IGET(1656B) + IGET(1756B) - 1 IF (IPRS2 .EQ. 3) GO TO 1510 C PRINT OUT SYS DISC TRACK ASSIGNMENTS CALL EXEC(2,LU2,ISYS,5) C IF(IPRS3.EQ.0) GO TO 1505 IPRAM = IPRS3 C ISTART = IGET(1656B) + IPRS3 IF(ISTART .GT. ISTOP ) GO TO 1530 IF(ISTART+IPRL4-1.LT.ISTOP)ISTOP=ISTART+IPRL4-1 1505 CALL DOIO(IGET(1656B)+IPRS3,ISTOP,LU2,IPRAM) C C IF(IPRAM(3).EQ.9999) RETURN 1510 IF(IPRS2.EQ.2) RETURN IF (INEED .EQ.0 ) RETURN C CALL EXEC(3,LU2+700B,1) CALL EXEC(2,LU2,IAUX,5) ISTART = ISTOP + 1 + IPRS3 ISTOP = ISTOP + INEED IF(ISTART .GT.ISTOP) GO TO 1530 IF(IPRS3 .EQ. 0 ) GO TO 1520 IPRAM = IPRS3 IF(ISTART+IPRL4-1 .LT. ISTOP)ISTOP = ISTART+IPRL4-1 1520 CALL DOIO(ISTART,ISTOP,LU2,IPRAM) RETURN 1530 CALL IWSUB(LU1) RETURN END C C C *****ANALYSIS OF THE SYSTEM***** C C SUBROUTINE ANSUB(IDISC,IFILE,IBUF,IPBUF,IDCB,IPRAM,LU2,LU1) DIMENSION IDISC(36),IFILE(10),IBUF(30),IPBUF(33),IDCB(144) DIMENSION IPRAM(6),ITABS(12),MATAB(6),MNP(3),IZZZ(3),IEPLST(38) DIMENSION IMLOC1(15),IMLOC(72),ICOMES(14) DIMENSION ILST(52),IEQLS(17) DIMENSION ICONT(3),IOFSET(5),IADR(4),LEN(5),ITAD(4),LLEN(5) C C DATA IEPLST/2H$O,2HP ,2H ,2H$L,2HIS,2HT ,2H$U,2HNP,2HE , & 2H$P,2HVC,2HN ,2H$C,2HIC,2H ,2H$P,2HOW,2HR ,2H$W,2HOR, & 2HK ,2H$L,2HST,2HM ,2H ,2H$P,2HET,2HB ,2H ,2H$D,2HMS, & 2H ,2H ,2H$C,2HIC,2H0 ,2H+1,2H3B/ DATA IMLOC1/2HAD,2HDR,2HES,2HS ,2HFO,2HR ,2HCU,2HRR, & 2HEN,2HT ,2HEQ,2HT ,2HEN,2HTR,2HY / DATA IMLOC/2HCH,2HAN,2H--,2HCU,2HRR,2HEN,2HT ,2HDM, & 2HA ,2HCH,2HAN,2HNE,2HL ,2HNU,2HMB,2HER, & 2HRQ,2HP1,2H--,2HCU,2HRR,2HEN,2HT ,2HEX, & 2HEC,2H R,2HEQ,2HUE,2HST,2H N,2HUM,2HBE,2HR , & 2HXE,2HQT,2H--,2HID,2H S,2HEG,2HME,2HNT, & 2H A,2HDD,2HR ,2HOF,2H C,2HUR,2HRE,2HNT,2H P, & 2HRO,2HGR,2HAM, & 2HXL,2HIN,2HK-,2H-I,2HD ,2HSE,2HGM,2HEN,2HT , & 2HAD,2HDR,2H O,2HF ,2HLA,2HST,2H P,2HRO,2HGR,2HAM/ DATA ILST/2HSK,2HED,2HD-,2H-S,2HCH,2HED,2HUL,2HE , & 2HLI,2HST, & 2HSU,2HSP,2H2-,2H-G,2HEN,2HER,2HAL,2H W, & 2HAI,2HT ,2HLI,2HST, & 2HSU,2HSP,2H3-,2H-M,2HEM,2HOR,2HY ,2HSU, & 2HSP,2HEN,2HD ,2HLI,2HST, & 2HSU,2HSP,2H4-,2H-D,2HIS,2HC ,2HSU, & 2HSP,2HEN,2HD ,2HLI,2HST/ DATA IEQLS/2HEQ,2HT ,2H #,2H ,2H ,2H ,2H ,2HDE, & 2HVI,2HCE,2H S,2HUS,2HPE,2HND,2H L,2HIS,2HT / DATA ITABS/2H$C,2HLA,2HS ,2HTA,2HBL,2HE , & 2H$R,2HNT,2HB ,2HTA,2HBL,2HE / DATA MATAB/2H$M,2HAT,2HA ,2HTA,2HBL,2HE / DATA MNP/2H$M,2HNP,2H / DATA IZZZ/2H$Z,2HZZ,2HZ / DATA ICONT/3,5,2/ DATA IOFSET/2H ,2H+1,2H+2,2H+3,2H+4/ DATA LEN/0,16,17,20,19/ DATA IADR/1673B,1700B,1717B,1720B/ DATA LLEN/0,10,12,13,12/ DATA ITAD/1711B,1713B,1714B,1715B/ DATA ICOMES/2H ,2HCU,2HRR,2HEN,2HT ,2HOC,2HCU,2HPA,2HNT,2H =, & 2H ,2H ,2H ,2H / C C ENTRY POINTS C DO 2010 I = 1,19,3 CALL EXEC(3,LU2+700B,1) CALL EXEC(2,LU2,IEPLST(I),3) CALL LISUB(IDISC,IFILE,IEPLST(I),IDCB,IPRAM,LU2,LU1) IF (IPRAM(3).EQ.9999) RETURN 2010 CONTINUE C C DO 2020 I = 22,30,4 CALL FNDET(IEPLST(I),IERR,IDCB,MYTYP,IWRD4) IF (IERR.NE.0) GO TO 2090 IF (MYTYP.EQ.3) CALL NFSUB(IEPLST(I),LU1) IF (MYTYP.EQ.3) GO TO 2020 INDX = 1 + (I-19)/4 DO 2025 J = 1,ICONT(INDX) IEPLST(I+3) = IOFSET(J) CALL EXEC(3,LU2+700B,1) CALL EXEC(2,LU2,IEPLST(I),4) CALL DOIO(IWRD4+J-1,IWRD4+J-1,LU2,IPRAM) IF (IPRAM(3).EQ.9999) RETURN 2025 CONTINUE C 2020 CONTINUE C C CALL FNDET(IEPLST(34),IERR,IDCB,MYTYP,IWRD4) IF (IERR.NE.0) GO TO 2090 IF (MYTYP.EQ.3) CALL NFSUB(IEPLST(34),LU1) IF (MYTYP.EQ.3) GO TO 2026 CALL EXEC (3,LU2+700B,1) CALL EXEC(2,LU2,IEPLST(34),5) CALL DOIO(IWRD4+13B,IWRD4+13B,LU2,IPRAM) IF (IPRAM(3).EQ.9999) RETURN C C MEMORY LOCATIONS C 2026 CALL EXEC (3,LU2+700B,1) CALL EXEC(2,LU2,IMLOC1,15) CALL DOIO(1660B,1672B,LU2,IPRAM) IF (IPRAM(3).EQ.9999) RETURN IPRAM = 12 IPRAM(3) = 1 CALL DOIO(1771B,1774B,LU2,IPRAM) IF (IPRAM(3).EQ.9999) RETURN IPRAM = 1 IPRAM(3) = 0 C IX = 1 DO 2027 I = 1,4 IX = IX + LEN(I) CALL EXEC (3,LU2+700B,1) CALL EXEC (2,LU2,IMLOC(IX),LEN(I+1)) CALL DOIO (IADR(I),IADR(I),LU2,IPRAM) IF (IPRAM(3).EQ.9999) RETURN 2027 CONTINUE C C DO 2030 K = 1,7,6 CALL FNDET(ITABS(K),IERR,IDCB,MYTYP,IWRD4) IF (IERR.NE.0) GO TO 2090 IF (MYTYP.EQ.3) CALL NFSUB(ITABS(K),LU1) IF (MYTYP.EQ.3) GO TO 2030 CALL EXEC (3,LU2+700B,1) CALL EXEC (2,LU2,ITABS(K),6) CALL DOIO(IWRD4+1,IWRD4+IGET(IWRD4),LU2,IPRAM) IF (IPRAM(3).EQ.9999) RETURN 2030 CONTINUE C C CALL FNDET(MNP,IERR,IDCB,MYTYP,IWRD4) IF (IERR.NE.0) GO TO 2090 IF (MYTYP.EQ.3) CALL NFSUB(MNP,LU1) IF (MYTYP.EQ.3) GO TO 2036 IMALG = 7 * (IGET(IWRD4)) CALL FNDET(MATAB,IERR,IDCB,MYTYP,IWRD4) IF (IERR.NE.0) GO TO 2090 IF (MYTYP.EQ.3) CALL NFSUB(MATAB,LU1) IF (MYTYP.EQ.3) GO TO 2036 CALL EXEC (3,LU2+700B,1) CALL EXEC (2,LU2,MATAB,6) C C DO 2035 I = IGET(IWRD4),IGET(IWRD4)+IMALG-1,7 CALL DOIO (I,I+6,LU2,IPRAM) IF (IPRAM(3).EQ.9999) RETURN IF (IGET(I+2).NE.0) GO TO 2032 ICOMES(12) = 2H GO TO 2034 2032 ICOMES(12) = IGET(IGET(I+2) +14B) ICOMES(13) = IGET(IGET(I+2) +15B) ICOMES(14) = IGET(IGET(I+2) +16B) 2034 CALL EXEC(2,LU2,ICOMES,-27) 2035 CONTINUE C C LISTS C 2036 IX = 1 DO 2037 I = 1,4 IX = IX + LLEN(I) CALL EXEC (3,LU2+700B,1) CALL EXEC (2,LU2,ILST(IX),LLEN(I+1)) CALL TRSUB(ITAD(I),(0),0,0,IPRAM,LU2) IF (IPRAM(3).EQ.9999) RETURN 2037 CONTINUE C C IEQTA = IGET(1650B) IEQTNO = IGET(1651B) C DO 2040 I = 1,IEQTNO CALL CNUMD(I,IEQLS(4)) CALL EXEC (3,LU2+700B,1) CALL EXEC(2,LU2,IEQLS,17) CALL TRSUB(IEQTA,(0),0,0,IPRAM,LU2) IF (IPRAM(3).EQ.9999) RETURN IEQTA = IEQTA+15 2040 CONTINUE C C CALL FNDET(IZZZ,IERR,IDCB,MYTYP,IWRD4) IF (IERR.NE.0) GO TO 2090 IF (MYTYP.EQ.3) CALL NFSUB(IZZZ,LU1) IF (MYTYP.EQ.3) GO TO 2060 CALL EXEC (3,LU2+700B,1) CALL EXEC (2,LU2,IZZZ,3) CALL DOIO(IWRD4,IWRD4,LU2,IPRAM) IF (IGET(IWRD4).LT.1) GO TO 2060 IWRD4 = IGET(IWRD4) IPRAM(3) = 1 C 2050 IF (IWRD4.LT.1) GO TO 2060 CALL DOIO(IWRD4-8,IWRD4-8,LU2,IPRAM) IF (IPRAM(3).EQ.9999) RETURN IPRAM(3) = 1 IWRD4 = IGET(IWRD4) GO TO 2050 C 2060 IPRAM(3) = 0 RETURN C C C 2090 CALL CNUMD(-(IERR),IFILE(8)) CALL EXEC (2,LU1,IFILE,10) C C RETURN END C C C *****DUMP THE FOUR MAPS TO THE LIST DEVICE***** C C SUBROUTINE MASUB(IARRAY) IMPLICIT INTEGER (A-Z) COMMON /CDA/ LU1, LU2, BPFLAG, MPFLAG, IOREC, SOREC, IERR, IWRN, & HIDEBP, HIDEMP, FIOPEN, INTER, IDCB(144), SDCB1(144), & SDCB2(144), IBUF(128), SBUF1(128), SBUF2(128), TRTAB(64) DIMENSION IARRAY(37),IMPMS(5) DATA IMPMS/2H ,2H ,2H ,2H M,2HAP/ CALL READF(IDCB,IERR,IBUF,128,IDMY,257) CALL ERR IOREC = 257 DO 2260 I = 1,4 GO TO (2210,2220,2230,2240) I C C SYSTEM MAP C 2210 IMPMS(1) = 2HSY IMPMS(2) = 2HST IMPMS(3) = 2HEM GO TO 2250 C C USER MAP C 2220 IMPMS(1) = 2HUS IMPMS(2) = 2HER IMPMS(3) = 2H GO TO 2250 C C PORT A MAP C 2230 IMPMS(1) = 2HPO IMPMS(2) = 2HRT IMPMS(3) = 2H A GO TO 2250 C C PORT B MAP C 2240 IMPMS(3) = 2H B C C 2250 CALL EXEC(2,LU2,IMPMS,5) IND = I*32-31 DO 2255 J = 1,4 CALL PACK(8,0,IBUF(IND),IARRAY) CALL EXEC(2,LU2,IARRAY,37) IND = IND + 8 2255 CONTINUE 2260 CONTINUE RETURN END C C INITIALIZATION SUBROUTINE C SUBROUTINE INIT IMPLICIT INTEGER (A-Z) COMMON /CDA/LU1, LU2, BPFLAG, MPFLAG, IOREC, SOREC, IERR, IWRN, & HIDEBP, HIDEMP, FIOPEN, INTER, IDCB(144), SDCB1(144), & SDCB2(144), IBUF(128), SBUF1(128), SBUF2(128), TRTAB(64), & PRFLAG DIMENSION PBUF(10), JBUF(30) C C INITIALIZATION ROUTINE... C C PARSE RUN STRING AND OPEN FILES; C ANNOUNCE NAME AND VERSION OF PROGRAM C C------------------------------------------------------------------------- BPFLAG = 0 MPFLAG = 0 HIDEMP = 0 HIDEBP = 0 FIOPEN = 0 IOREC = 0 SOREC = 0 IWRN = 0 IERR = 0 PRFLAG = 1 C C GET PARAMETERS C LU1 = 1 CALL EXEC(14,1,JBUF,-60) CALL ABREG(A,B) C C WIPE OUT "RU,CDA4," C ICHAR = 1 CALL NAMR(PBUF,JBUF,B,ICHAR) CALL NAMR(PBUF,JBUF,B,ICHAR) C C SET COMMAND INPUT LU # C LU1 = LOGLU(IDMY) LU2 = LU1 + 200B INTER = IFTTY(LU1) C C ANNOUNCE PROGRAM AND VERSION C CALL EXEC(2,LU1,38HCDA4 THE CRASH DUMP ANALYZER 01/01/80,19) C C GET ENTRY POINT SNAPSHOT FILE C CALL NAMR(PBUF,JBUF,B,ICHAR) IF (IAND(PBUF(4),3B).EQ.3)GO TO 20 11 CALL EXEC (2,LU1,30HBAD ENTRY POINT SNAPSHOT FILE ,15) GO TO 32 20 CALL OPEN(SDCB1,IERR,PBUF,1,PBUF(5),PBUF(6)) IF(IERR.LT.0)GO TO 11 IF(IERR.EQ.1)GO TO 30 CALL EXEC (2,LU1, & 40HENTRY POINT SNAPSHOT FILE IS NOT TYPE 1 ,20) STOP 1003 C C GET SYSTEM SNAPSHOT FILE C 30 CALL NAMR(PBUF,JBUF,B,ICHAR) IF (IAND(PBUF(4),3B).EQ.3)GO TO 40 31 CALL EXEC(2,LU1,24HBAD SYSTEM SNAPSHOT FILE,12) 32 CALL EXEC(2,LU1, & 50HFORMAT: RU, entry point snapshot, system snapshot ,25) STOP 1004 40 CALL OPEN(SDCB2,IERR,PBUF,1,PBUF(5),PBUF(6)) IF(IERR.LT.0)GO TO 31 IF(IERR.EQ.1)GO TO 50 CALL EXEC(2,LU1,34HSYSTEM SNAPSHOT FILE IS NOT TYPE 1,17) STOP 1005 C C REQUEST FILE NAME C 50 IERR=0 CALL EXEC(2,LU1, & 50HPLEASE SPECIFY THE CRASH FILE WITH THE FI COMMAND ,25) RETURN END END$ FTN4,Q,T SUBROUTINE CTSUB(TAB,ENT) IMPLICIT INTEGER (A-Z) COMMON /CDA/ LU1, LU2, BPFLAG, MPFLAG, IOREC, SOREC, IERR, IWRN, & HIDEBP, HIDEMP, FIOPEN, INTER, IDCB(144), SDCB1(144), & SDCB2(144), IBUF(128), SBUF1(128), SBUF2(128), TRTAB(64) COMMON /MEM/ M(1) COMMON /CT/ CTTAB(1) C C CTSUB IMPLEMENTS THE CT (COMPARE TABLE) COMMAND FOR CDA4 C C CTTAB IS A DATA TABLE GIVING THE NAMES OF THE TABLES THAT C CAN BE PROCESSED. IT APPEARS AS AN ASSEMBLY LANGUAGE SOURCE C FILE. THE FORMAT FOR AN ENTRY: C C WORD 1 POINTER TO TABLE CODE AND DESCRIPTION C 2 LENGTH OF TABLE ENTRY (I.E., THE TABLE DESCRIBED) C 3 POINTER TO THE BIT MASK FOR COMPARISON C 4 ADDRESS OF A ROUTINE TO SET UP THE TABLE LENGTH C AND ADDRESS. C C THE END OF THE TABLE IS INDICATED BY A ZERO IN WORD 1. C C THE TABLE CODE AND DESCRIPTION HAS THE FOLLOWING FORMAT: C C WORD 1 LENGTH IN WORDS (=N) - 2 ASCII DIGITS C 2 TWO LETTER TABLE CODE C 3-N TEXT OF DESCRIPTION C C WORDS 2-N ARE PRINTED AS TITLES AND FOR THE HELP FUNCTION C C THE BIT MASK PACKS 16 BITS OF COMPARISON INFORMATION INTO A C WORD; IF A BIT IS ON, THE WORD WILL BE COMPARED. BIT 15 IS C USED FIRST; IF MORE THAN 16 BITS ARE NEEDED, ADDITIONAL WORDS C ARE USED. C C C THE ARRAY M (AN EXTERNAL DEFINED WITH CTTAB) IS USED TO REFER C TO MAIN MEMORY. SINCE M IS EQUATED TO 0B, M(J+1) WILL GIVE C THE CONTENTS OF LOCATION J. (NOTE THAT FORTRAN USES 1-ORIGIN C INDEXING). ALSO, NOTE THAT C C CALL EXEC(2, LU2, M(J), LEN) C C WILL PRINT THE DATA STORED STARTING AT LOCATION J, WHILE C C CALL EXEC(2, LU2, IGET(J), LEN) C C WILL NOT. (THIS PROGRAM REDEFINES IGET ANYWAY) C C-------------------------------------------------------------------------- C C CHECK FOR HELP REQUEST (CT,??) C AND PROCESS IF FOUND C 10 IF(TAB.EQ.0) ENT=0 IF(TAB.NE.2H??) GO TO 30 DO 20 J = 1,32767,4 IF(CTTAB(J).EQ.0) RETURN CALL PRNT(M(CTTAB(J)+1)) 20 CONTINUE C C SEARCH FOR THE RIGHT TABLE CODE C 30 DO 40 J = 1,32767,4 IF(CTTAB(J).EQ.0) GO TO 50 IF(M(CTTAB(J)+2).EQ.TAB) GO TO 60 IF(TAB.NE.0) GO TO 40 IF(CTPRC(J,ENT).NE.0) RETURN 40 CONTINUE C C ENTRY WAS NOT FOUND C 50 IF(TAB.EQ.0)RETURN CALL PRNT(28H14TABLE REQUESTED NOT FOUND ) RETURN C C TABLE FOUND - PROCESS ENTRY C 60 IDMY = CTPRC(J,ENT) RETURN END INTEGER FUNCTION CTPRC(J,ENT) IMPLICIT INTEGER (A-Z) COMMON /CDA/LU1, LU2, BPFLAG, MPFLAG, IOREC, SOREC, IERR, IWRN, & HIDEBP, HIDEMP, FIOPEN, INTER, IDCB(144), SDCB1(144), & SDCB2(144), IBUF(128), SBUF1(128), SBUF2(128), TRTAB(64) COMMON /MEM/ M(1) COMMON /CT/ CTTAB(1) COMMON /CTPR/TLEN, TADR, TYP DIMENSION OBUF(144), MES1(11) DATA MES1/2H11,2H E,2HNT,2HRY,2H N,2HUM,2HBE,2HR ,2H--,2H--,2H--/ C C CTPRC COMPARES A TABLE OR A SINGLE ENTRY (IF ENT IS 0 OR >0, C RESPECTIVELY). J IS A SUBSCRIPT FOR CTTAB, INDICATING WHICH TABLE C TO PROCESS (SEE CTSUB FOR MORE INFO) C THE RETURN VALUE IS NON-ZERO IS A BREAK WAS DETECTED. C C----------------------------------------------------------------------------- C C SET TITLE FLAG C TITLE = 1 CTPRC = -1 IF(ENT.NE.0) TITLE=0 C C SET TABLE SIZE AND ADDRESS C IERR = 0 CALL JMP(CTTAB(J+3)) IF(TYP.EQ.3) GOTO 130 C C SET LIMITS FOR COMPARE C L1 = TADR L2 = TADR + (TLEN - 1)*CTTAB(J + 1) IF(ENT.EQ.0) GO TO 10 C C SET ENTRY LIMITS; CHECK ENTRY # IS IN RANGE C L1 = TADR + (ENT - 1)*CTTAB(J + 1) L2 = L1 IF (ENT.LE.TLEN .AND. ENT.GE.0) GO TO 10 CALL PRNT(28H14ENTRY NUMBER OUT OF RANGE ) RETURN C C DO COMPARISON C 10 ELEN = CTTAB(J + 1) DO 120 TADDR = L1, L2, ELEN FLAG = 0 PADDR = CTTAB(J + 2) DO 40 K = 0, ELEN - 1, 16 WORD = M(PADDR+1) PADDR = PADDR + 1 DO 30 L = 0,15 IF (WORD.GE.0) GO TO 20 IF ( IGET(TADDR+K+L) .NE. SGET(TADDR+K+L) ) & FLAG = 1 20 WORD = WORD + WORD 30 CONTINUE 40 CONTINUE C C**** IF COMPARE FAILED, PRINT ENTRY C PRINT TITLE IF NEEDED; PRINT ENTRY NUMBER (ALWAYS) C IF(FLAG.EQ.0) GO TO 120 IF(TITLE.NE.0) CALL PRNT(M(CTTAB(J)+1)) CALL CNUMD((TADDR-L1)/ELEN + 1, MES1(9)) CALL PRNT(MES1) CALL PRNT(4H02 ) TITLE = 0 C C NOW FORMAT ENTRY C PADDR = CTTAB(J+2) DO 110 K = 0, ELEN - 1, 16 DO 60 L = 1,144 OBUF(L) = 2H 60 CONTINUE WORD = M(PADDR+1) PADDR = PADDR + 1 DELTA = 5 DO 90 L = 0,15 IF (K+L.GE.ELEN) GO TO 100 CALL OCT(IGET(TADDR+K+L),OBUF(L*4+DELTA)) IF (WORD.GE.0) GO TO 80 OBUF(L*4+DELTA-1) = 2H * IF (IGET(TADDR+K+L) .NE. SGET(TADDR+K+L)) & CALL OCT(SGET(TADDR+K+L), OBUF(L*4+DELTA+72)) 80 WORD = WORD + WORD IF (L.EQ.7) DELTA = 9 90 CONTINUE C C CONVERT ADDRESSES TO OCTAL; THEN PRINT TWO LINES (8 WORDS) C IF MORE THAN 8 WORDS WERE FORMATTED ABOVE, THEN PRINT ANOTHER C TWO LINES. C 100 IF(IFBRK(IDMY).NE.0)GO TO 131 CALL OCT(TADDR+K,OBUF) CALL OCT(TADDR+K+8,OBUF(37)) CALL EXEC(2,LU2,OBUF,36) CALL EXEC(2,LU2,OBUF(73),36) CALL PRNT(4H02 ) IF(L.LT.8) GO TO 110 CALL EXEC(2,LU2,OBUF(37),36) CALL EXEC(2,LU2,OBUF(109),36) CALL PRNT(4H02 ) 110 CONTINUE 120 CONTINUE C C PRINT A BLANK LINE TO SEPARATE TABLES C 130 CTPRC = 0 131 CALL PRNT(4H02 ) RETURN END ASMB,R,L HED CTAB - DATA FOR TABLE COMPARE ROUTINE NAM CTAB,7 ENT MEM COMMON AREA - EQUATED TO 0 - FOR FTN USE ENT CT COMMON AREA - DATA TABLES FOR CTSUB ENT CTPR COMMON AREA - FOR PASSING DATA BACK TO CTSUB * EXT IGET,FNDET,JRETN * A EQU 0 B EQU 1 * * DEFINE CDA COMMON AREA * EXT CDA EXT EQUIVALENT TO FORTRAN NAMED COMMON * MEM EQU 0 EQUATING MEM TO 0 ALLOWS FORTRAN TO REFER TO * LOCATION J IN MEMORY AS M(J+1). MEM IS THE * NAME OF A COMMON AREA CONTAINING (ONLY) M. * ************************************************************************** * * CT - DATA TABLE FOR CTSUB. THE FORMAT OF THE DATA AREA IS DESCRIBED * IN CTSUB. NOTE HOW THE POINTERS ARE SET UP WITH LABELS. NOTE THE * REGULARITY OF THE LABELS: --DSC IS USED FOR THE DESCRIPTION, * --MSK IS USED FOR THE BIT MASK, AND --SET IS USED FOR THE SETUP * ROUTINE. -- IS THE SAME AS THE TABLE CODE. * ************************************************************************** * SUP SUPRESS 2-N WORDS FOR EACH LINE * CT DEF CMDSC COMMUNICATION AREA - POINTER TO DESCRIPTION DEF 133B LENGTH OF TABLE ENTRY DEF CMMSK POINTER TO MASK DEF CMSET ADDR OF ROUTINE TO SET TABLE LEN & ADDR * DEF DRDSC DRIVER MAPPING TABLE DEF 1 DEF DRMSK DEF DRSET * DEF EQDSC EQT TABLE DEF 15 DEF EQMSK DEF EQSET * DEF KBDSC KEYWORD BLOCK DEF 1 DEF KBMSK DEF KBSET * DEF MADSC MATA TABLE DEF 7 DEF MAMSK DEF MASET * DEF MPDSC MEMORY PROTECT FENCE TABLE DEF 6 DEF MPMSK DEF MPSET * DEF TRDSC TRACK MAP TABLE #1 DEF 17 DEF TRMSK DEF TRSET * DEF T2DSC TRACK MAP TABLE #2 DEF 3 DEF T2MSK DEF T2SET * DEF 0 **END OF TABLE** * * TABLE TITLES/DESCRIPTIONS * CMDSC ASC 12,12CM COMMUNICATIONS AREA MADSC ASC 08,08MA $MATA TABLE KBDSC ASC 09,09KB KEYWORD BLOCK TRDSC ASC 12,12TR TRACK MAP TABLE #1 T2DSC ASC 12,12T2 TRACK MAP TABLE #2 EQDSC ASC 10,10EQ EQUIPMENT TABLE DRDSC ASC 13,13DR DRIVER MAPPING TABLE MPDSC ASC 16,16MP MEMORY PROTECT FENCE TABLE * * COMPARISON BIT MASKS * CMMSK OCT 017740 0 001 111 111 100 000 OCT 000400 0 000 000 100 000 000 OCT 000000 0 000 000 000 000 000 OCT 000777 0 000 000 111 111 111 OCT 160377 1 110 000 011 111 111 OCT 160000 1 110 000 000 000 000 MAMSK OCT 001000 0 000 001 000 000 000 KBMSK OCT 100000 1 000 000 000 000 000 TRMSK OCT 177777 1 111 111 111 111 111 OCT 100000 1 000 000 000 000 000 T2MSK OCT 160000 1 110 000 000 000 000 EQMSK OCT 060000 0 110 000 000 000 000 DRMSK OCT 100000 1 000 000 000 000 000 MPMSK OCT 176000 1 111 110 000 000 000 * * CHUNKS OF CODE * NOTE THAT THE CHUNKS ARE ASSUMED TO BE * CALLED BY THE 'JMP' SUBROUTINE; THEY * SHOULD RETURN TO 'JRETN' WITH A JUMP. * CMSET LDA D1 STA TLEN LDA B1645 STA TADR JMP JRETN * MASET JSB FND GET ADDR ASC 3,$MATA OF $MATA STA TADR JSB FND GET NO OF ASC 3,$MNP ENTRIES STA TADR2 GET VALUE JSB IGET OF CELL DEF *+2 DEF TADR2 STA TLEN JMP JRETN * KBSET JSB IGET GET POINTER DEF *+2 DEF B1657 FROM COMMUNICATIONS AREA STA TADR STA TADR2 * * NOW FIND THE END OF THE TABLE * KB1 JSB IGET LOAD TABLE WORD DEF *+2 DEF TADR2 SZA END? ISZ TADR2 NO - INCR SZA YES - END? JMP KB1 NO - CONTINUE LDA TADR2 CMA,INA SUBTRACT ADA TADR TADR CMA,INA TO GIVE COUNT STA TLEN SAVE AND JMP JRETN RETURN * TRSET JSB FND POINT TO TABLE ASC 3,$TB31 STA TADR LDA D1 SET LENGTH STA TLEN AND JMP JRETN RETURN * T2SET JSB FND GET TABLE ASC 3,$TB32 ADDRESS STA TADR2 INA STA TADR GET VALUE JSB IGET OF CELL DEF *+2 DEF TADR2 CMA,INA BEGINNING OF TABLE HAS -LENGTH STA TLEN JMP JRETN * EQSET JSB IGET GET ADDRESS DEF *+2 DEF B1650 FROM COMMUNICATIONS AREA STA TADR JSB IGET GET LENGTH DEF *+2 DEF B1651 FROM COMMUNICATIONS AREA STA TLEN JMP JRETN * DRSET JSB FND GET ADDRESS ASC 3,$DVMP FROM THE ENTRY POINT STA TADR JSB IGET GET LENGTH DEF *+2 DEF B1651 FROM COMMUNICATIONS AREA STA TLEN (SAME LENGTH AS EQT TABLE) JMP JRETN * MPSET JSB FND GET ADDRESS ASC 3,$MPFT FROM THE ENTRY POINT STA TADR2 GET VALUE JSB IGET DEF *+2 DEF TADR2 STA TADR LDA D1 ONLY ONE ENTRY STA TLEN JMP JRETN * ***** END OF CODE CHUNKS (AND CT TABLE AREA) * * * CTPR IS USED TO PASS INFORMATION FOR CTSUB AND PRSUB * * CTPR EQU * TLEN DEF *-* THE TABLE LENGTH (WORDS, POSITIVE) TADR DEF *-* THE TABLE ADDRESS TYP DEF *-* RETURN VALUE FROM FIND OPERATION * * FND SUBROUTINE - FINDS AN ENTRY POINT IN THE SNAPSHOT FILE * * CALL: JSB FND * ASC 3,-NAME- * ON RETURN, THE A REGISTER HAS THE ADDRESS OF THE ENTRY POINT * FND NOP ENTRY JSB FNDET CALL FORTRAN ROUTINE DEF *+6 DEF FND,I ENTRY POINT IN ASCII DEF CDA+6 ERROR FLAG (IERR) DEF CDA+156 DCB (SDCB1) DEF TYP KLUDGE DEF FHLD GETS ENTRY POINT ADDRESS LDA FND INCR ADA D3 RETURN STA FND ADDRESS LDA FHLD LOAD ENTRY POINT ADDRESS JMP FND,I RETURN * FHLD DEF *-* GETS ENTRY POINT ADDRESS IDMY DEF *-* DUMMY PARAMETER TADR2 DEF *-* TEMP * * CONSTANTS * B377 OCT 000377 B1774 OCT 177400 B1645 OCT 001645 B1657 OCT 001657 B1650 OCT 001650 B1651 OCT 001651 D1 DEC 1 D2 DEC 2 D3 DEC 3 D4 DEC 4 D5 DEC 5 D6 DEC 6 D7 DEC 7 D12 DEC 12 M67 DEC -67 END FTN4,L PROGRAM CDA4B(5),24999-16197 REV.2024 IMPLICIT INTEGER (A-Z) COMMON /CDA/LU1, LU2, BPFLAG, MPFLAG, IOREC, SOREC, IERR, IWRN, & HIDEBP, HIDEMP, FIOPEN, INTER, IDCB(144), SDCB1(144), & SDCB2(144), IBUF(128), SBUF1(128), SBUF2(128), TRTAB(64) C COMMON /CDASG/ RTNA, IPBUF(33), IPRAM(6), IARRAY(64), IDISC(36), & IGO(35), IGO2(35), IFILE(10), JBUF(30), IOP, LEN C EQUIVALENCE (IPBUF(2),IPRS1),(IPBUF(6),IPRS2),(IPBUF(10),IPRS3), & (IPBUF(14), IPRS4), (IPBUF(18), IPRS5), (IPBUF(22), IPRS6), & (IPBUF(26), IPRS7), (IPBUF(30), IPRS8) C C THIS SEGMENT HANDLES SOME OF THE COMMANDS FOR CDA4 C C SELECT THE APPROPRIATE SUBROUTINE: C GO TO (100, 100, 100, 100, 100, 100, 100, 100, 100, 100, & 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, & 100, 100, 100, 124, 125, 126, 100, 128, 100, 130, & 100, 100, 100, 100, 100) IOP C 100 CALL PRNT(16H07INTERNAL ERROR) GO TO 1 124 CALL DB(LU1, IDCB) GO TO 1 125 CALL WHZIT(LU2, SDCB1, IPRS2) GO TO 1 126 CALL EXEC(2,LU1,31HBE OF GOOD CHEER SAM IS COMING!,-31) GO TO 1 128 CALL FISUB(JBUF,LEN) GO TO 1 130 CALL VESUB(IPRS2,SDCB1) GO TO 1 C C NOW RETURN TO MAIN C 1 CALL JMP(RTNA) END END$ FTN4,Q,T SUBROUTINE FISUB(JBUF,LEN) IMPLICIT INTEGER (A-Z) C COMMON /CDA/ LU1, LU2, BPFLAG, MPFLAG, IOREC, SOREC, IERR, IWRN, & HIDEBP, HIDEMP, FIOPEN, INTER, IDCB(144), SDCB1(144), & SDCB2(144), IBUF(128), SBUF1(128), SBUF2(128), TRTAB(64) C COMMON /CDA2/ DS1, DS2, MLIM, MSTAT, DPLIM C COMMON /CDA3/ TIM(5), YR C C DIMENSION JBUF(1),IPBUF(10),T(2) DIMENSION MES1(24), MES2(8), MES3(21), MES4(21) DATA MES1/2H24,2HTI,2HME,2H O,2HF ,2HCR,2HAS,2HH / DATA MES2/2H08,2HRE,2HV ,2HCO,2HDE,2H..,2H..,2H../ DATA MES3/2H21,2H..,2H..,2H..,2H P,2HAG,2HES,2H O,2HF ,2HDR, & 2HIV,2HER,2H P,2HAR,2HTI,2HTI,2HON,2HS ,2HDU,2HMP, & 2HED/ DATA MES4/2H21,2HDE,2HAD,2H S,2HPO,2HT ,2HIS,2H B,2HET,2HWE, & 2HEN,2H ,2H..,2H..,2H..,2H A,2HND,2H ,2H..,2H.., & 2H../ C C FISUB IMPLEMENTS THE FI COMMAND C IT SETS UP THE LIMITS FOR THE 'DEAD AREA', INITIALIZES C MSTAT, MLIM, AND DPLIM, AND SETS UP THE TRANSLATION TABLE C (TRTAB) C C------------------------------------------------------------------------- C C CLOSE THE OLD FILE IF NECESSARY, PARSE THE FILE NAME AND OPEN C THE NEW FILE C IF(FIOPEN.EQ.1)CALL CLOSE(IDCB) FIOPEN = 0 ICHAR = 1 CALL NAMR(IPBUF,JBUF,LEN,ICHAR) CALL NAMR(IPBUF,JBUF,LEN,ICHAR) IF(IAND(IPBUF(4),3B).EQ.3)GO TO 10 CALL EXEC(2,LU1,18HINVALID FILE NAME ,9) RETURN 10 CALL OPEN(IDCB,IERR,IPBUF,1,IPBUF(5),IPBUF(6)) IF (IERR.GE.0)GO TO 20 CALL EXEC(2,LU1,16HCANNOT OPEN FILE,8) RETURN 20 IF(IERR.EQ.1) GO TO 25 CALL EXEC(2,LU1,24HCRASH FILE IS NOT TYPE 1,12) RETURN 25 IERR = 0 C C**** DETERMINE DUMP TYPE C C CHECK FILE LENGTH >= 257 C CALL READF(IDCB,IERR,IBUF,128,IDMY,257) IF(IERR.EQ.0) GO TO 30 CALL PRNT(32H16FILE TOO SMALL - MAPS MISSING ) RETURN C C INITIALIZE STATE C 30 FIOPEN = 1 MPFLAG = 0 HIDEMP = 0 BPFLAG = 0 HIDEBP = 0 SOREC = 0 IOREC = 0 DS1 = 0 DS2 = 0 C PRINT CRASH TIME AND DATE C CALL FNDET(5H$TIME,IERR,SDCB1,TYP,WD4) IF(TYP.NE.3 ) GO TO 31 CALL PRNT(20H10CRASH TIME UNKNOWN) GO TO 32 31 T(1) = IGET(WD4) T(2) = IGET(WD4 + 1) CALL TMVAL(T,TIM) DCNT = IGET(WD4 + 2) YR = DCNT/365 + 1970 TIM(5) = DCNT - (DCNT/365)*365 + 1 CALL JFTIM(MES1(10)) CALL PRNT(MES1) C C PRINT CRASH REV CODE C 32 CALL FNDET(5H$DATC,IERR,SDCB1,TYP,WD4) IF(TYP.NE.3 )GO TO 33 CALL PRNT(18H09REV CODE UNKNOWN) GO TO 34 33 CALL CNUMD(IGET(WD4),MES2(6)) CALL PRNT(MES2) C C CHECK FOR STANDALONE DUMP C (4666 AND 77777B ARE MAGIC NUMBERS) C 34 IF(IGET(77677B).NE.4666.OR.IGET(77676B).NE.77777B) GO TO 35 CALL PRNT(18H09STANDALONE DUMP ) DPLIM = 48 MSTAT = IGET(77674B) DS1 = IGET(77675B) DS2 = 77777B GO TO 47 C C CHECK FOR GENNED IN DUMP C 35 CALL FNDET(5H\DUMP,IERR,SDCB1,TYP,WD4) IF(TYP.NE.3 ) GO TO 40 C C NOT GENNED IN - SOURCE UNKNOWN C CALL PRNT(32H16DUMP TYPE CANNOT BE DETERMINED) DS1 = 77400B DS2 = 77777B MSTAT = 0 DPLIM = 32 GO TO 47 C C GENNED IN C 40 CALL PRNT(16H08GENNED IN DUMP) DS1 = 1 DS2 = 0 MSTAT = IGET(WD4 - 1) C C FIGURE OUT HOW MANY DRIVER PTTN PAGES WERE DUMPED C CALL FNDET(5H$MRMP,IERR,SDCB1,TYP,WD4) IF(TYP.NE.3 ) GO TO 45 CALL PRNT(16H08$MRMP MISSING ) MLIM = 0 RETURN 45 DPLIM = IAND(IGET(IGET(WD4)),1777B) 47 IF(DPLIM.LT.32) DPLIM = 32 IF(DPLIM.GE.64) DPLIM = 48 CALL CNUMD(DPLIM-32,MES3(2)) CALL PRNT(MES3) C C PRINT DEAD SPOT (IF THERE IS ONE) C CALL OCT(DS1,MES4(13)) CALL OCT(DS2,MES4(19)) IF(DS1.LE.DS2) CALL PRNT(MES4) C C**** SET UP THE TRANSLATION TABLE; C VERIFY THAT THE FILE CONTAINS ENOUGH DATA FOR EACH MAP C MLIM = 0 CALL READF(IDCB,IERR,IBUF,128,IDMY,258+(DPLIM-32)*8) IOREC = 0 IF(IERR.EQ.0) GO TO 50 MLIM = 0 CALL PRNT(46H23DRIVER PTTNS, SYSTEM AND USER MAPS SUPRESSED) RETURN C C SET UP THE TABLE C 50 I = 258 + (DPLIM - 32)*8 CALL READF(IDCB,IERR,IBUF,128,IDMY,257) IOREC = 0 CALL ERR DO 80 J = 1,64 K = IAND(IBUF(J),1777B) IF (K.LT.DPLIM)GO TO 60 TRTAB(J) = I I = I+8 GO TO 70 C ELSE 60 TRTAB(J) = K*8 + 1 IF (K.GT.31) TRTAB(J) = TRTAB(J) + 1 C C CHECK THE SYSTEM WAS COMPLETELY DUMPED C 70 IF (J.NE.33) GO TO 80 CALL READF(IDCB,IERR,IDMY,1,IDMY,I-1) IOREC = 0 IF(IERR.EQ.0) GO TO 80 MLIM = 1 CALL PRNT(32H16SYSTEM AND USER MAPS SUPRESSED) RETURN 80 CONTINUE C C CHECK THE USER MAP IS THERE C CALL READF(IDCB,IERR,IDMY,1,IDMY,I-1) IOREC = 0 IF(IERR.EQ.0) GO TO 90 MLIM = 2 CALL PRNT(20H10USER MAP SUPRESSED) RETURN 90 MLIM = 3 RETURN END END$ ASMB,R,Q,C,N * * NAME: DBUGR * SOURCE: 92067-1???? * RELOC: 92067-16??? * PGMR: B.S.,G.A.,D.D.,D.S.,J.N. * * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** * * HED DBUG(USER VERSION) NAM DB,7 92067-16??? REV.GAA- 790313 ENT DB EXT EXEC,IFBRK,$LIBX,$LIBR,LOGLU,IGET,FNDET SUP * * A EQU 0 B EQU 1 R EQU 1 HED SYMBOL TABLES * E N D * * USER DEFINED SYMBOL TABLE AREA * * SYMBOLS WILL RESIDE IN IDENTICAL FORMAT TO TABLE "ISL" * FOLLOWING THIS TABLE IN MEMORY. THAT FORMAT IS: * * 4 TO 6 CHARACTERS IN SYMBOL- * * ENTRY 1 - 1ST WORD(1ST 3 CHARACTERS OF SYMBOL) IN SQOZE CODE * ENTRY 2 - 2ND WORD(2ND 3 CHARACTERS OF SYMBOL) IN SQOZE CODE * ENTRY 3 - OPCODE * * 3 OR LESS CHARACTERS IN SYMBOL- * * ENTRY 1 - SYMBOL WORD IN SQOZE CODE * * ENTRY 2 - MAY BE USED FOR A VALUE * END BSS 50 SYMBOL TABLE FREE AREA SKP * I S L * * INSTRUCTIONS SYMBOL TABLE * * CONTAINS SYMBOLS FOR THE 2100 ALTER SKIP,SHIFT ROTATE AND * I O INSTRUCTIONS SET IN SQOZE CODE. TABLE ENTRIES ARE IN * THE FOLLOWING FORMAT: * * 4 TO 6 CHARACTERS IN SYMBOL- * * ENTRY 1 - 1ST WORD(1ST 3 CHARACTERS OF SYMBOL) IN SQOZE CODE * ENTRY 2 - 2ND WORD(2ND 3 CHARACTERS OF SYMBOL) IN SQOZE CODE * ENTRY 3 - OPCODE * * 3 OR LESS CHARACTERS IN SYMBOL- * * ENTRY 1 - SYMBOL WORD IN SQOZE CODE * * ENTRY 2 - MAY BE USED FOR A VALUE * ISL EQU * OCT 45 . LOC NOP USED AS THE LOCATION COUNTER OCT 2755 .. DDOT NOP * * I S L 2 * * REMAINDER OF TABLE "ISL" SOMETIMES REFERRED TO DIRECTLY AND * SOMETIMES REFERRED TO AS A PART OF TABLE "ISL" * ISL2 EQU * OCT 44115,0,1000 ALS OCT 44475,0,1100 ARS OCT 130316,0,1200 RAL OCT 130324,0,1300 RAR OCT 44114,0,1400 ALR OCT 61053,0,1500 ERA OCT 60473,0,1600 ELA OCT 44100,0,1700 ALF OCT 47215,0,5000 BLS OCT 47575,0,5100 BRS OCT 130366,0,5200 RBL OCT 130374,0,5300 RBR OCT 47214,0,5400 BLR OCT 61054,0,5500 ERB OCT 60474,0,5600 ELB OCT 47200,0,5700 BLF ISL3 EQU * OCT 52273,0,2400 CLA OCT 52343,0,3000 CMA OCT 51523,0,3400 CCA OCT 52274,0,6400 CLB OCT 52344,0,7000 CMB OCT 51524,0,7400 CCB SEZ OCT 133674,0,2040 SEZ OCT 133674,0,6040 SEZ CLE OCT 52277,0,2100 CLE OCT 52277,0,6100 CLE OCT 52277,0,40 CLE OCT 52277,0,4040 CLE OCT 52277,35,40 CLES OCT 52347,0,2200 CME OCT 52347,0,6200 CME OCT 51527,0,2300 CCE OCT 51527,0,6300 CCE OCT 131645,0,2001 RSS OCT 131645,0,6001 RSS OCT 134723,0,2020 SSA OCT 75213,0,2004 INA OCT 135353,0,2002 SZA OCT 134724,0,6020 SSB OCT 75214,0,6004 INB OCT 135354,0,6002 SZB SLA OCT 134273,0,10 SLA OCT 134273,0,2010 SLA OCT 44115,0,20 ALS LOWER OCT 44475,0,21 ARS LOWER OCT 130316,0,22 RAL LOWER OCT 130324,0,23 RAR LOWER OCT 44114,0,24 ALR LOWER OCT 61053,0,25 ERA LOWER OCT 60473,0,26 ELA LOWER OCT 44100,0,27 ALF LOWER SLB OCT 134274,0,4010 SLB OCT 134274,0,6010 SLB OCT 47215,0,4020 BLS LOWER OCT 47575,0,4021 BRS LOWER OCT 130366,0,4022 RBL LOWER OCT 130374,0,4023 RBR LOWER OCT 47214,0,4024 BLR LOWER OCT 61054,0,4025 ERB LOWER OCT 60474,0,4026 ELB LOWER OCT 47200,0,4027 BLF LOWER OCT 23,100000 I O15 OCT 15,1000 C OCT 72016,0,102000 HLT HLT EQU *-1 OCT 52300,0,103100 CLF OCT 135000,0,102100 STF STF EQU *-1 OCT 133715,0,102200 SFC OCT 133735,0,102300 SFS OCT 111303,0,102400 MIA OCT 111304,0,106400 MIB OCT 120373,0,102600 OTA OCT 120374,0,106600 OTB OCT 134775,0,102700 STC OCT 52275,0,106700 CLC OCT 106203,0,102500 LIA OCT 106204,0,106500 LIB OCT 44544,0,101020 ASR OCT 44536,0,100020 ASL ASL EQU *-1 OCT 107044,0,101040 LSR OCT 107036,0,100040 LSL LSL EQU *-1 OCT 131574,0,101100 RRR OCT 131566,0,100100 RRL RRL EQU *-1 OCT 51432,0,101741 CAX OCT 51433,0,101751 CAY OCT 51502,0,105741 CBX OCT 51503,0,105751 CBY OCT 53233,0,101744 CXA OCT 53234,0,105744 CXB OCT 53303,0,101754 CYA OCT 53304,0,105754 CYB OCT 153132,0,101747 XAX OCT 153133,0,101757 XAY OCT 153202,0,105747 XBX OCT 153203,0,105757 XBY OCT 105576,0,105763 LBT OCT 133476,0,105764 SBT OCT 106013,0,101727 LFA OCT 106014,0,105727 LFB OCT 110663,0,105702 MBI OCT 110701,0,105704 MBW OCT 112373,0,105705 MWI OCT 112411,0,105707 MWW OCT 131623,0,101730 RSA OCT 131624,0,105730 RSB OCT 132013,0,101731 RVA OCT 132014,0,105731 RVB OCT 154043,0,101722 XMA OCT 154044,0,105722 XMB OCT 154065,0,105721 XMS OCT 56052,0,105761 DSX OCT 56053,0,105771 DSY OCT 75552,0,105760 ISX OCT 75553,0,105770 ISY OCT 110660,0,105703 MBF OCT 112370,0,105706 MWF OCT 122103,0,101712 PAA OCT 122104,0,105712 PAB OCT 122153,0,101713 PBA OCT 122154,0,105713 PBB OCT 135303,0,101710 SYA OCT 135304,0,105710 SYB OCT 143123,0,101711 USA OCT 143124,0,105711 USB OCT 154057,0,105720 XMM OCT 63432,0,105100 FIX OCT 63616,0,105120 FLT OCT 133714,0,105767 SFB "CR" EQU O15 SKP DOUBL EQU * OCT 111763,0,100200 MPY OCT 55230,0,100400 DIV OCT 55376,0,104200 DLD OCT 56046,0,104400 DST OCT 62706,0,105000 FAD OCT 63120,0,105060 FDV OCT 63662,0,105040 FMP OCT 64224,0,105020 FSB OCT 43422,0,105746 ADX OCT 43423,0,105756 ADY OCT 105532,0,101742 LAX OCT 105533,0,101752 LAY OCT 105602,0,105742 LBX OCT 105603,0,105752 LBY OCT 105722,0,105745 LDX OCT 105723,0,105755 LDY OCT 153773,0,101724 XLA OCT 153774,0,105724 XLB OCT 133432,0,101740 SAX OCT 133433,0,101750 SAY OCT 133502,0,105740 SBX OCT 133503,0,105750 SBY OCT 135022,0,105743 STX OCT 135023,0,105753 STY OCT 134737,0,105714 SSM OCT 100223,0 JLY JLY OCT 105762 OCT 100463,0 JPY JPY OCT 105772 * REMAINING INSTRUCTIONS ARE IN THE 21MX BASE SET * BUT ARE NOT SIMULATED BY DDT AND CANNOT BE TRACED. OCT 55272,0,105732 DJP IVINS EQU *-1 OCT 55275,0,105733 DJS OCT 134172,0,105734 SJP OCT 134175,0,105735 SJS OCT 142372,0,105736 UJP OCT 142375,0,105737 UJS OCT 154423,0,101725 XSA OCT 154424,0,105725 XSB STTP2 EQU * OCT 100575,0,105715 JRS OCT 153223,0,101726 XCA OCT 153224,0,105726 XCB OCT 51476,0,105766 CBT OCT 110676,0,105765 MBT OCT 51475,0,105774 CBS OCT 133475,0,105773 SBS OCT 136575,0,105775 TBS OCT 112341,0,105777 MVW OCT 52371,0,105776 CMW STTP EQU * SKP * DSPTB DEF PLUS SPACE DEF EXCL ! DEF ASCIN " DEF NUMSN # DEF EXI $ DEF PCT % DEF DAQ & DEF ASO ' DEF PFIX ( DEF EXASC ) DEF STAR * DEF PLUS + CMADD DEF COMMA , DEF MINUS - DEF DOT . DEF BAR / NMFLG BSS 1 NOT USED FOR DISPATCHING (ASCII # 0) BSS 1 NOT USED FOR DISPATCHING (ASCII # 1) BSS 1 NOT USED FOR DISPATCHING (ASCII # 2) BSS 1 NOT USED FOR DISPATCHING (ASCII # 3) BSS 1 NOT USED FOR DISPATCHING (ASCII # 4) BSS 1 NOT USED FOR DISPATCHING (ASCII # 5) TEMP4 BSS 1 NOT USED FOR DISPATCHING (ASCII # 6) TEMP3 BSS 1 NOT USED FOR DISPATCHING (ASCII # 7) TEMP2 BSS 1 NOT USED FOR DISPATCHING (ASCII # 8) TEMP1 BSS 1 NOT USED FOR DISPATCHING (ASCII # 9) DEF COLON : DEF SEMI ; DEF LSSN < DEF EQLS = DEF GRTR > DEF MSTAT ? DEF EXA @ DEF AT A DEF BRK B DEF CT C DEF PNCH D DEF EAS E DEF FT F DEF GO G DEF HT H DEF ERR I DEF USMAP J DEF KILL K DEF TABL L DEF MT M DEF NWS N DEF BPM O DEF PROC P DEF QT Q DEF RSET R DEF ST S DEF TRACE T DEF ECSL U DEF VFY V DEF WDS W DEF XEC X DEF LOAD Y DEF ZRO Z DEF SBRK [ DEF ALT \ ERRX DEF ERR ] DEF UPARW ^ DEF LARR _ * UNL IFN LST UNL XIF LST HED DBUG INITIALIZATION * * PNT10 DEF MSG01 MSG01 OCT 6412 CR/LF UNL LST ASC 6,START DBUGR UNL LST OCT 6412 CR LF ASC 1,// * .DBUG NOP WHERE LOADER WILL PLACE TRUE RETURN. $DDT NOP EVERYONE'S ENTRY POINT DBUGR EQU $DDT DB EQU $DDT UNL IFZ LST JSB SVST NOMINAL ENTRY POINT LDB .DBUG DETERMINE IF CALLED FROM LDA $DDT LOADER($DDT = 0)OR SZA DIRECTLY. LDB $DDT,I SET EXIT ADDRESS STB DDOT FOR PROCEED UNL XIF IFN LST LDB $DDT,I GET THE RETURN ADDRESS STB .DBUG AND SAVE IT CCA UNL XIF LST ISZ $DDT STEP TO POSSIBLE LU ADDRESS. SZA IF APPENDED BY LOADER OR CPB $DDT IF THERE IS NO LU GIVEN, JMP TST THEN GO GET LOG LU OR LU 1. * LDA $DDT,I YES GET IT LDA A,I TO A TST1 AND O77 ISOLATE IT IOR O2500 MAKE HONEST MODE STA LU SAVE AS THE LU ISZ $DDT STEP TO THE DCB ADDRESS LDA $DDT,I GET THE DCB ADDRESS STA DCB AND SAVE IT HERE JSB EXEC GET TYPE CODE DEF TSTRT DEF O15 (DEC 13) DEF LU PCH DEF CH TEMP TSTRT LDA PCH,I GET EQT WORD 5 AND C374 KEEP TYPE STA TMODE SET MODE (0= '\' #0= '\\' LDB PNT10 PRINT 'START JSB OUTMS DBUGR' MESSAGE. JMP LSE O2500 OCT 2500 * TST JSB LOGLU GO RECOVER LOG DEF *+2 LU OR IF NONE, DEF LU THEN USE LU 1. JMP TST1 A-REG = LU#. C374 OCT 37400 HED DBUG - CHARACTER DISPATCH * * LSE RSS CLEARED ON FIRST ENTRY JMP LSE1 * UNL IFZ LST LDA BIX GET THE ADDRESS TO USE AGE AND G74 FOR BREAK INSTRUCTIONS XOR BIX SAVE THE ADDRESS ONLY STA DSYMX SAVE IT FOR BREAK UNL XIF LST LDA LNEV SET FENCES CMA,INA FOR STA LNEV EVAL CHECKS LDA LXEV MUST BE NEG CMA,INA STA LXEV * UNL IFZ LST LDA 1777B SET DM BOUNDS UNL XIF IFN CCA SET UP THE MOST CLE,ERA WE CAN HAVE UNL XIF LST STA CEND SET END OF MEMORY INA STA UPBD CMA,INA STA MUPBD * LSE1 JSB CRLF CLA PROTECT STA PFLAG STORES LSF LDA PM STA EXPM LSF2 CLA FROM TABP. STA TRAC CLEAR TRACE COUNT STA LSE CLEAR FIRST TIME RSS STA $DDT CLEAR JSB ENTRY POINT. STA LFLG LDA O3 STA LL LDA CEND STA UL * LSS CLA FROM LIM SET. STA CHI STA WRD STA CLEFG CLEAR CLE FLAG STA CMFLG CLEAR COMMA FLAG STA INSTR STA ALTMI * LDA CAD SSN STA SGN CLA LSQ STA ONM STA DNM CLA,CLE CLE IS DECORATION. STA SYM STA SYM+R STA LETF STA CHC LDB SYMXI STB SYMX STA WSD MAKE A NO-OP. LSR0 EQU * STA ASCI SKP * LSR EQU * JSB TTYOP STA CH CPA O177 JMP DEL LDB LFP CPA O12 JMP LFCRT LDB CRP CPA O15 JMP LFCRT LDB CH ADB DSPP LDB B,I ADA M40 SSA LDB ERRX 0-37, ERROR UNLESS... LDA CH CPA O11 LDB TBP CPA O176 LDA O33 CPA O33 JMP ALTMD STB PR ADA M72 SSA,RSS JMP LT 72-177, CHECK FOR LETTER. ADA O12 SSA JMP LSCG 0-57, NOT NUMBER OR LETTER. JSB BUMP PROCESS DIGIT JMP L1 ASCI NOP M40 OCT -40 M41 OCT -41 M72 OCT -72 O11 OCT 11 O176 OCT 176 O1000 OCT 1000 O3 OCT 3 O32 OCT 32 CRP DEF CR CAD DEF PLUS DSYMX DEF SYMX,I CONFIGURED ON 1ST ENTRY DSPP DEF DSPTB-40B EXPM NOP INSTR NOP LETF NOP LFP DEF LF SGN NOP PR NOP TBP DEF TAB UNL IFN LST O33 OCT 33 C3007 OCT 3007 JSBII JSB 0,I UNL XIF LST SKP * LT ADA M41 CHECK FOR LETTER LDB ALTMI CCE,SSA CH42 SEZ,SZB SZB: ALT MODE PRESENT? JMP LSET OPERATOR. ADA O32 SSA JMP LSCG 72-100 * L0 ISZ LETF PROCESS LETTER L ADA O12 MAKE SQOZE CODE L1 INA LDB CHC CPB O3 ISZ SYMX ADB M6 CH125 CLE,SSB,INB,RSS SSB,RSS: MORE THAN SIX CHARS? JMP LSR ISZ CHC ISZ CHI LDB SYMX,I TIMES 50 RBL,RBL ADB SYMX,I BLF,RBR ADB A STB SYMX,I USED AS CONSTANT LDA ASCI ALF,ALF ADA CH JMP LSR0 * LFCRT XOR C3007 SWAP CR AND LF STB PR JSB TYO LDA JSBII ISZ A DELAY TO LET... JMP *-1 C. R. COMPLETE. * LSET ADA M6 72-177 SSA,RSS CHECK FOR 141-177 JMP ERR YES, LOSE. LSCG LDB PR GET DISPATCH ADDRESS ADB LNEV CLA FOR MT,FT CH54 OCT 5254 SSB=RBL,SLB JMP PR,I NO-EVAL, DISPATCH NOW. CPA LETF IF NO LETTERS, JMP LSCI ANY OPERAND IS NUMERIC. LDB SYM+R SZB JMP NOTOP SKP OPLK LDB A SEARCH OP TABLE ADB OPPTR LDB B,I GET SYMBOL CPB SYM JMP OPFND INA SZB JMP OPLK * NOTOP JSB EVS EVALUATE SYMBOLIC TERM. JMP SGN,I DEFINED; GO COMBINE TERMS. LDA CH125 U - UNDEFINED JMP ERRP * OPFND ALF,RAR MOVE INDEX TO OP POSN ALF,CLE,SLA,ALF ALWAYS SKIPS: USED AS CONSTANT CPA IADR,I STA INSTR LSCI LDA ONM COMBINE OPERANDS JMP SGN,I PERFORM SIGN OPERATION. SKP * B U M P * * UPDATES CURRENT NUMERIC ENTRY * * LDA * JSB BUMP * P+1 * * BUMP NOP LDB ONM PROCESS DIGIT BLF,RBR SAVE CURRENT ADB A NUMBER AS STB ONM OCTAL LDB DNM SAVE RBL,RBL CURRENT ADB DNM NUMBER RBL AS ADB A DECIMAL STB DNM JMP BUMP,I HED NON-EVALUATION OPERATORS * DOT CPA CHC IF FIRST CHAR, ISZ LETF TREAT AS LETTER. LDB DNM STB ONM LDA O32 BECOMES SQOZE CODE. JMP L * DEL LDA CH130 X JMP ERRP * SYMO LDA O117 SYMBOL TABLE OVERFLOW RSS * BADP LDA CH120 P JSB TYO * ERR LDA O77 ? UNL IFN XIF BRK EQU ERR PNCH EQU ERR GO EQU ERR TABL EQU ERR TRACE EQU ERR VFY EQU ERR XEC EQU ERR LOAD EQU ERR ZRO EQU ERR SBRK EQU ERR USMAP EQU ERR UNL XIF LST ERRP JSB TYO OTST LDA TAS REGISTER OPEN? CPA LIMBO JMP LSE NO. JMP TABP YES. * ASCIN LDA ASCI ASCII INPUT JMP N1 * DAQ LDA LWT DEFINE SYMBOL AS ADDRESS JSB ADRC CLEARS E LDA B ELA,SLA,RAR CLEAR SIGN & SKIP * COLON LDA LOCP,I DEFINE SYMBOL AS LOCATION LDB LFLG SZB LDA LL LDB LETF CHECK SYMBOL SZB,RSS JMP ERR JSB DEFS JMP TABP O117 OCT 117 LWT NOP TAS DEF SYM ADDRESS OF OPEN REGISTER SKP * ALTMD LDA O134 BACKSLASH JSB TYO ECHO LDA O134 IF SET FOR A ESC GOBBLER LDB TMODE THEN SZB JSB TYO SEND TWO '\' 'S * ALT ISZ ALTMI JMP LSR * ECSL LDA TMODE 'U' CHANGE ESC DOUBLE '\' OPTION SZA CLA,RSS CCA STA TMODE JMP OTST * TMODE NOP INITIAL SET FOR NON '\' GRABBER * END OF ESSENTIAL NO-EVALS. * HED MISCELLANEOUS OPERATORS * KILL LDA ISEND KILL SYMBOLS STA STEND JMP LSE * MT INA FT ADA STED JMP N1 * BPM LDA PM STA BM JMP OTST * HT INA CT INA ST INA AT ADA STPPP LDA A,I USED AS CONSTANT STA PM SET MODE STA EXPM JMP OTST * QT LDA LWT JMP N1 * STAR LDA LOCP,I N1 CLB STB ALTMI ISZ CHI JMP LSQ RESET SYMBOL STUFF. * PFIX CCA UNPROTECT STA PFLAG STORES JMP LSF * LNEV DEF * END OF NO-EVALS. BM DEF NUMP STPPP DEF ADRPP LINK TO MASTER MODE TABLE PFLAG NOP PROTECT FLAG SKP * MINUS CMA,INA PLUS ADA WRD JMP WSET * COMMA IOR WRD WSET STA WRD RETURN HERE FROM SIGN OP. LDA PR LDB PR CPB CMADD IF COMMA SET COMMA FLAG STB CMFLG ADB LXEV CH57 OCT 5257 SSB=RBL,SLB. SKIP UNLESS SIGN OP JMP SSN SET SIGN FOR NEXT TIME. * LDA INSTR CHECK FOR PAGE ERROR CSNZA SZA,RSS JMP NAOP NOT ADDRESSABLE. LDA WRD AND G76 PAGE BITS? LDB A SAVE 'EM SZA,RSS JMP NAOP BASE PAGE. XOR IADR AND G76 CSZA SZA JMP BADP YOU CAN'T GET THERE FROM HERE. LDA O2000 PUT IN PAGE BIT. XOR B NAOP XOR WRD RESTORE LOCAL ADDRESS. ADA INSTR STA WRD CLB STB INSTR LDB CHI SZB,RSS LDA LWT STA LWT JMP PR,I DISPATCH TO PROCESSOR (EVALS) SKP * LXEV DEF * END OF COMBINING OPERATORS. * * BEGIN ESSENTIAL EVALS. * GRTR JSB DMCHK CHECK IF IN PARTITION STA UL LIMIT SET CSKP RSS * LSSN STA LL ISZ LFLG JMP LSS * RSET LDB A SET RADIX ADA M2 CH120 CLE,SSA JMP ERR ADA M40 SSA,RSS JMP ERR STB RADIX JMP LSE M2 OCT -2 O2000 OCT 2000 G76 OCT 76000 HED REGISTER EXAMINATION ASO LDA ASCPP PRINT AS ASCII JMP SETM * EXCL LDA INSPP PRINT AS INSTRUCTION JMP SETM * LARR LDA ADRPP PRINT AS ADDRESS JMP SETM * EQLS LDA NUMPP PRINT AS NUMBER SETM STA PR ONE TIME MODE SET LDB ALTMI SZB STA EXPM TEMP MODE SET LDA LWT JSB PR,I JMP TABP * SEMI JSB EXPM,I PRINT IN CURRENT MODE JMP TABP * EXASC LDB ASCPP EXAMINE AS ASCII JMP EXAM * EXI LDB ALTMI $ WITH NO ESC IS SYMBOL CHAR. CMB,INB,SZB ESC ENTERED?? JMP EXI1 YES GO ADJUST * LDA O33 NO PICK UP SQOZE '$' JMP L0 GO PROCESS SYMBOL * EXI1 CMB ESC $ IS PRINT AS INSTR., ESC ESC $ STB ALTMI IS SAME AS ESC / EXCEPT SET TMP. MODE LDB INSPP EXAMINE AS INSTRUCTION JMP EXAM * EXA LDB ADRPP EXAMINE AS ADDRESS JMP EXAM * NUMSN LDB NUMPP EXAMINE AS NUMBER JMP EXAM * PCT JSB STORE CLB STB CHI FOOL BAR LOGIC * BAR LDB EXPM USE TEMP MODE EXAM STB STORE SET IMMEDIATE MODE LDB ALTMI SZB JSB ADRC LDA LWT ELA,CLE,ERA PURGE INDIRECT BIT LDB CHI SZB,RSS ADDRESS SPECIFIED? JMP TA6 NO, USE LWT LDB STORE YES, SET TEMP MODE, TOO. STB EXPM JMP TA5 * TAB JSB STORE LDB ALTMI SZB JSB ADRC LDA LWT TA3 STA TAS JSB CRLF LDA TAS TA4 ELA,CLE,ERA PURGE INDIRECT BIT STA TAS JSB ADRP PRINT ADDRESS JSB TYO PRINT / LDB EXPM STB STORE SET TO USE TEMP MODE LDA TAS TA5 STA LOCP,I SET LOCATION COUNTER TA6 STA TAS STA IADR JSB DMCHK TEST IF IN PARTITION JSB PTAB UNL IFZ LST LDA ACCA B LOADED BY PTAB-TYO-TTYOP LDA TAS,I UNL XIF IFN LST LDA TAS CHECK IF IN A REG. CLE,ERA IF NOW ZERO THEN WAS 0 OR 1 CMA,CLE,INA SET E IF IN REG. LDA ACCA GET REG. TO A. B LOADED ABOVE SEZ SKIP LOAD IF POSSIBLE DM LDA TAS,I ELSE GET A OR B TO A SEZ IF ALREADY HAVE IT JMP TA7 SKIP CALL ON IGET * JSB IGET USE DISC READ ROUTINE TO LOAD DEF *+2 DEF TAS UNL XIF LST TA7 STA LWT JSB STORE,I PRINT CONTENTS TABP JSB PTAB JMP LSF2 * CR JSB STORE JMP LSF * UPARW JSB STORE CCA ADA LOCP,I DECREMENT LOCATION COUNTER JMP TA3 * LF JSB STORE CLA,INA NEXT LOCATION ADA LOCP,I JMP TA4 "/" OCT 57 SLASH SPACE OCT 40 "M" OCT 115 SKP * A "?" DISPATCHES HERE MSTAT JSB PTAB 3 SPACES LDA "M" M JSB TYO LDA "S" S JSB TYO LDA CH40 SPACE JSB TYO LDA "=" = JSB TYO LDA CH40 SPACE JSB TYO LDA M6 INITIALIZE STA TEMP1 COUNTER TO 6 RSA GET MEM STATUS MST01 STA TEMP2 SAVE ROTATED STATUS SSA IS BIT15=1? JSB ONE YES JSB ZERO NO LDA TEMP2 RESTORE ROTATED STATUS RAL ROTATE NEXT BIT ISZ TEMP1 DONE? JMP MST01 NO,CONTINUE ALF,ALF YES,GET RAL,RAL ORIGINAL A AND O1777 MASK BP FENCE LDB O10 WRITE BP FENCE JSB PN ON CONSOLE JSB PTAB 3 SPACES JMP LSF2 "=" OCT 75 "S" OCT 123 O10 OCT 10 O1777 OCT 01777 UNL IFZ LST SKP USMAP JSB CRLF CR LF JSB PTAB 3 SPACES USM01 JSB TTYOP GET 1ST OPERATOR INPUT CPA "A" ABORT? JMP USM02 YES CPA "CR" CR? JMP USMAP YES,NO ACTION CPA SPACE SPACE? JMP USM01 YES,IGNORE AND O177 SAVE 1ST ALF,ALF CHARACTER STA TEMP1 IN UPPER BYTE JSB TTYOP GET 2ND OPERATOR INPUT AND O177 FORM IOR TEMP1 WORD CPA "SM" SYSTEM MAPS? JMP SYSTM YES CPA "UM" USER MAPS? JMP USER YES CPA "XL" CROSS LOAD? JMP XLOAD YES CPA "PA" PORT A? JMP PORTA YES CPA "PB" PORT B? JMP PORTB YES JMP ERR NO,NOT DEFINED,ERROR USM02 JSB PTAB 6 JSB PTAB SPACES JMP LSF2 "PA" ASC 1,PA "PB" ASC 1,PB "SM" ASC 1,SM "UM" ASC 1,UM "XL" ASC 1,XL O20 OCT 20 O72 OCT 72 SKP USER LDA O72 : JSB TYO LDA USA JMP RMAP GET USER MAPS USE00 CLA SET UP INDEX STARTING AT 0 USE01 JSB SHMAP 2 MAPS CPA O20 DONE? RSS YES JMP USE01 NO,CONTINUE JSB CRLF CR LF JMP USMAP SYSTM LDA O72 : JSB TYO LDA SYA JMP RMAP GET SYSTEM MAPS SKP XLOAD CLA CLEAR STORE FLAG STA XADR CLEAR LAST ADDRESS LDA IMAPS GET SYSTEM MAPS JSB $LIBR ****PROTECT FOR OLD MX'S NOP SYA JSB $LIBX DEF *+1 DEF *+1 X01 JSB CRLF CR LF JSB PTAB 6 JSB PTAB SPACES LDA "XL" X ALF,ALF JSB TYO LDA "XL" L JSB TYO JSB PTAB 3 SPACES JSB GETAD GET ADDRESS FROM OPERATOR JMP ERR INPUT ERROR CPB M1 ABORT? JMP USMAP SEE IF DONE SZB,RSS ANY CROSS OPERATION? JMP X01 NO,NO ACTION STA TEMP1 SAVE STA XADR ADDRESS JSB PTAB 3 SPACES ALF,RAL COMPUTE PAGE ADDRESS RAL AND O37 ADA IMAP LDA A,I GET MAP SSA READ PROTECTED JMP DMCK6 YES, GO TO DM ERROR LDA XADR RESTORE A XLA TEMP1,I CROSS LOAD JSB NUMP NO,DISPLAY CONTENTS JMP X01 SEE IF MORE CROSS OPERATIONS * PORTA LDA O72 : JSB TYO LDA PAA JMP RMAP READ PORT A MAPS PORTB LDA O72 : JSB TYO LDA PBA JMP RMAP GET PORT B MAPS * RMAP STA RMAP1 LDA IMAPS BUFFER ADDRESS,I JSB $LIBR UNPROTECT FOR OLD MX'S NOP RMAP1 NOP JSB $LIBX DEF *+1 DEF USE00 USA USA SYA SYA PAA PAA PBA PBA O37 OCT 37 UNL XIF LST SKP * G E T A D * * TAKE AN ADDRESS FROM OPERATOR * * JSB GETAD * P+1 * P+2 * GETAD NOP CLB ASSUME SIGN IS + INITIALLY STB ONM AND CLEAR CHARACTER COUNT STB DNM AND CLEAR OCTAL NUMBER STB CHC AND CLEAR DECIMAL NUMBER GETA5 JSB TTYOP TAKE 1ST CHARACTER CPA "A" ABORT? JMP GETA1 YES CPA "LF" LF? JMP GETA4 YES CPA "^" ^? JMP GETA7 YES CPA SPACE SPACE? JMP GETA5 YES,IGNORE IT RSS NO,TREAT 1ST CHARACTER AS NUMBER GETA2 JSB TTYOP TAKE NEXT NUMBER CPA "CR" DEFAULT? JMP GETA1 YES CPA "/" DONE? JMP GETA3 YES ADA M72 NO,CHARACTER SSA,RSS >71B? JMP GETAD,I YES,ERROR ADA O12 NO,CHARACTER SSA <60B? JMP GETAD,I YES,ERROR JSB BUMP UPDATE NUMBER'S VALUE LDA CHC CHARACTER CPA O5 COUNT ALREADY =5? JMP GETAD,I YES,THIS ONE MAKES IT AN ERROR ISZ CHC NO,BUMP CHARACTER COUNT JMP GETA2 CONTINUE GETA3 LDA ONM A=NUMBER RSS GETA1 CCB,RSS SET ABORT FLAG GETA6 LDB CHC SET UP DEFAULT FLAG ISZ GETAD ADJUST RETURN JMP GETAD,I GETA7 CCB,RSS GETA4 CLB,INB LDA XADR PREVIOUS SZA ADDRESS? JMP GETA8 CLB JMP GETAD,I NO,ERROR GETA8 ISZ CHC CLEAR ABORT FLAG LDA XADR DISPLAY ADA B ADJUST ADDRESS STA XADR JSB NUMP ADDRESS LDA "/" / JSB TYO LDA XADR A=ADDRESS=NUMBER JMP GETA6 "^" OCT 136 "LF" OCT 012 O5 OCT 05 * ONE NOP LDA O61 PRINT A 1 JSB TYO AND A SPACE LDA CH40 AND RETURN P+2 JSB TYO ISZ ONE JMP ONE,I * ZERO NOP LDA O60 PRINT A 0 JSB TYO AND A SPACE LDA CH40 JSB TYO JMP ZERO,I O60 OCT 60 O61 OCT 61 XADR NOP UNL IFZ LST HED NUMBER AND SYMBOL PRINT SKP * S H M A P * * DISPLAYS 2 MAP VALUES ON CONSOLE * * LDA * LDB * JSB SHMAP * P+1 * SHMAP NOP STA TEMP1 SAVE INDEX JSB CRLF CR LF JSB PTAB 6 JSB PTAB SPACES LDA TEMP1 PRINT MAP LDB O10 REGISTER # JSB PN ON CONSOLE LDA TEMP4 SINGLE ADA M2 CHARACTER SSA,RSS MAP REG. #? JMP SHM01 NO LDA SPACE YES,NEED AN JSB TYO ADDITIONAL SPACE SHM01 LDA "=" = JSB TYO LDA TEMP1 GET MAP ADA IMAP REGISTER LDA A,I VALUE LDB O10 WRITE IT ON JSB PN THE CONSOLE LDA TEMP4 NEGATE # OF CHARACTERS ADA M6 <6 THAT WERE IN THE STA TEMP4 NUMBER JUST DISPLAYED SSA,RSS 6 CHARACTERS? JMP SHM02 YES SHM03 LDA SPACE NO,NEED JSB TYO ADDITIONAL ISZ TEMP4 SPACES JMP SHM03 SHM02 JSB PTAB 3 SPACES LDA TEMP1 PRINT MAP ADA O20 REGISTER #+16 LDB O10 ON CONSOLE JSB PN LDA "=" = JSB TYO LDA TEMP1 GET MAP ADA O20 REGISTER ADA IMAP +16 LDA A,I VALUE LDB O10 WRITE IT ON JSB PN THE CONSOLE LDA TEMP1 LEAVE INA INDEX+1 JMP SHMAP,I IMAPS DEF MAPS,I IMAP DEF MAPS MAPS BSS 32 UNL XIF LST SKP * G E T N M * * TAKES OPERATOR NUMERICAL INPUT * * LDA * JSB GETNM * P+1 * P+2 * GETNM NOP JSB NUMP DISPLAY OLD VALUE JSB PTAB 3 SPACES GET05 JSB TTYOP TAKE 1ST CHARACTER CLB ASSUME SIGN IS + INITIALLY STB CHC AND CLEAR CHARACTER COUNT STB ONM AND CLEAR OCTAL NUMBER STB DNM AND CLEAR DECIMAL NUMBER CPA "A" ABORT? JMP GET01 YES CPA SPACE SPACE? JMP GET05 YES,IGNORE IT CPA NEG IS IT -? INB YES,SET - FLAG STB NMFLG SAVE + OR - FLAG CPA POS IS IT +? RSS YES SZB NO,1ST CHARACTER TREATED AS 1ST NUMBER? GET02 JSB TTYOP GET CHARACTER CPA "CR" DONE? JMP GET06 YES ADA M72 NO,CHARACTER SSA,RSS >71B? JMP GETNM,I YES,ERROR ADA O12 CHARACTER SSA <60B? JMP GETNM,I YES,ERROR JSB BUMP UPDATE NUMBER'S VALUE LDA CHC CHARACTER COUNT CPA O6 ALREADY = 6? JMP GETNM,I YES,THIS ONE MAKES IT AN ERROR ISZ CHC NO,BUMP CHARACTER COUNT JMP GET02 CONTINUE GET06 LDA ONM A=NUMBER LDB NMFLG NEGATIVE SZB,RSS NUMBER? JMP GET04 NO,POSITIVE,LEAVE IT ALONE CMA,INA,RSS YES GET01 CCB,RSS SET ABORT FLAG ON EXIT GET04 LDB CHC SET UP DEFAULT FLAG ON EXIT ISZ GETNM ADJUST RETURN JMP GETNM,I O6 OCT 6 POS OCT 53 NEG OCT 55 SKP * STORE NOP UNL IFN LST SZB ANYTHING TYPED?? JMP MPMSG REMIND HIM WE CANN'T DO IT * UNL XIF IFZ LST SZB,RSS ANYTHING TYPED? JMP STORX NO, RETURN. * LDB CLEFG WAS CLE FLAG SET SZB,RSS JMP STORW NO JUST GO STORE IT LDB A AND O2000 YES,WHICH GROUP SZA ADA O40 SRG CLE=2100B ADA O40 ASG CLE=40B IOR B AND MERGE WITH INSTRUCTION * STORW STA TEMP3 SAVE VALUE LDB PFLAG UNPROTECT SZB THE STORE? JMP STORZ LDA TAS NO CHECK FOR MP SZA A OR B REGISTER CPA O1 JMP STORY YES, STORE IT JSB MPCHK CHECK FOR MP & DM ERROR JMP MPMSG GO PRINT "MP?" STA IADR JSB ADCHK CHECK FOR DBUGR OVERWRITE JMP STORY OK TO STORE STORZ JSB $LIBR YES,GO NOP PRIVELEGED STORY LDB TAS SZB,RSS STORE TO A REG LDB DACCA YES GET PHONY A REG ADDRESS STB TAS LDA TEMP3 RESTORE VALUE LDB ACCB RESTORE B STA TAS,I STB ACCB LDB PFLAG JUST STORE SZB,RSS UNPROTECTED? JMP STORX NO,GO ON JSB $LIBX YES,GO DEF *+1 UNPRIVELEGED DEF STORX UNL XIF LST STORX LDB LIMBO STB TAS CLOSE REGISTER JMP STORE,I UNL IFZ LST HED BREAKPOINT * BRK SZB USER ENTER ADDRESS? JMP BRK1 YES,SEE IF VALID FOR BREAKPOINT LDA LIMBO NO,USE CURRENT ADDRESS BRK2 STA BPADR SET BREAKPOINT ADDRESS JMP LSE BRK1 STA TEMP4 SAVE ADDRESS JSB MPCHK CHECK FOR MEMORY PROTECT JMP MPMSG GO PRINT ERROR STA IADR JSB ADCHK CHECK FOR DBUGR OVERLAP LDA A,I GET INSTRUCTION JSB AHEAD NO,VALID FOR BREAKPOINT? JMP PR9 NO,DON'T ALLOW IT LDA TEMP4 YES,RESTORE ADDRESS JMP BRK2 * TRAP NOP STA ACCA SAVE A LDA BADD,I GET VALUE TO BE TESTED XOR BVAL TEST VALUE AND BMSK MASK VALUE SZSKP RSS JMP BIXI LDA ACCA ISZ CHC PROCEED COUNT JMP BIX JSB SVST CCA ADA TRAP JSB BRKMS GO DO BREAK MESSAGE JSB PTAB JMP LSF2 G24 OCT 24000 RSS RSS BIXI LDA ACCA JMP BIX SKP * ************************************************************************ * * ROUTINE .SDBG: * * .SDBG PROVIDES A SPECIAL ENTRY POINT TO DBUGR FOR SEGMENTED * PROGRAMS LOADED ON-LINE USING THE RTE-IV RELOCATING LOADER. * THE LOADER INSERTS THE FOLLOWING SUBROTINE(*.STDB*)FROM THE * SYSTEM LIBRARY WITH EACH SEGMENT: * * EXT .SDBG * ENT .DBSG,.STDB * .STDB JSB .SDBG * .DBSG NOP * END .STDB * * THE LOADER PLACES THE ACTUAL ENTRY POINT ADDRESS FOR THE SEGMENT * INTO *.DBSG*. THE SEGMENT'S ID SEGMENT'S ENTRY POINT IS SETUP * TO POINT TO *.STDB*. THIS EFFECTIVELY INSERTS DBUGR JUST BEFORE * ENTRY INTO THE SEGMENT. * * THE MESSAGE 'SEGMENT BREAK' IS PRINTED AND A PSUEDO BREAKPOINT * OCCURS AT THE SEGMENT'S ENTRY POINT ADDRESS. IF * THE CURRENT TRUE BREAKPOINT IS WITHIN THE OLD SEGMENT(E.G., ABOVE * THE MAIN'S LAST WORD), THEN THE MESSAGE 'BREAKPOINT REMOVED' IS * ALSO ISSUED. FINALLY, DBUGR CONTINUES AND GETS THE NEXT * DEBUG COMMAND. * * WHEN A PROCEED COMMAND OCCURS, DBUGR WILL CONTINUE AT THE ENTRY * POINT OF THE SEGMENT. * ************************************************************************ * .SDBG NOP * JSB SVST SAVE STATUS OF SYSTEM. * LDX O5 GET SEGMENT NAME LDA ACCA ADA O14 RAL MAKE BYTE ADDRESS LDB SNAME DESTINATION ADDRESS RBL MAKE BYTE ADDRESS MBF GET NAME FROM SYSTEM MAPS * LDA .SDBG,I STA DDOT SAVE RETURN ADDRESS STA TRAP LDB XB COMPUTE ADDRESS ADB O15 OF 'HIGH MAIN+1'. XLB B,I DETERMINE IF OLD BREAKPOINT IS CMB,INB ABOVE END OF MAIN PROGRAM-- ADB BPADR E.G., WITHIN THE OLD SEGMENT. SSB IF OLD BREAKPOINT IS WITHIN JMP SDBG1 LDB BPADR IF BP IN SEGMENT LDA LIMBO THEN MUST REMOVE STA BPADR LDA OLDBK AND FIX WIPED OUT INSTRUCTION STA B,I * SDBG1 STB SDTMP SAVE OLD BPADR LDA SBNAM IS IT THIS SEGMENT LDB SNAME CMW O3 JMP SDBG4 NOP * LDA SBNM1 LDB SDTMP FETCH OLD BPADR SSB IF BP NOT IN SEGMENT OR CPA M1 DONT STOP FOR ALL SEGMENTS RSS JMP SDBG6 THEN CONTINUE CCA SET SEGMENT BREAK FLAG STA SBFLG * SDBG3 LDA DDOT JSB BRKMS PRINT BREAK MESSAGE JSB CRLF * LDA SDTMP WAS BREAKPOINT REMOVED SSA JMP LSE NO,GO GET NEXT COMMAND JSB ADRP YES,PRINT 'S+XXXXX LDB PNOBK BREAKPOINT REMOVED!' JSB OUTMS JMP LSE AND GET NEXT COMMAND * SDBG4 CCA SET SEGMENT BREAK FLAG STA SBFLG LDA SGA IS THIS A SEGMENT BREAK SZA,RSS JMP SDBG5 YES GO BREAK * LDA SGA,I NO,IS BREAKPOINT LEGAL JSB AHEAD JMP SDBG5 NO ,GO BREAK LDA SGA YES,SET AND LDB BPADR STB SDTMP SET FOR BP REMOVED MESSAGE STA BPADR CPB LIMBO IF SAME AS PREVIOUSLY RSS SET THEN CONTINUE JMP SDBG3 ELSE BREAK SDBG6 JSB RSST RESTORE STATUS JMP TRAP,I * SDBG5 CCA CLEAR BREAKPOINT REMOVED FLAG STA SDTMP JMP SDBG3 GO PRINT SEGMENT BREAK UNL XIF LST SGA BSS 1 SGB BSS 1 SBFLG OCT 0 SBNAM DEF SBNM1 SBNM1 OCT 0 ASC 2, BYADD BSS 1 BLKBL ASC 1, "]" OCT 135 "B" OCT 102 SDTMP BSS 1 OLDBK BSS 1 O14 OCT 14 * UNL IFZ LST XB EQU 1732B SNAME DEF SNAM1 PSGMS DEF SGMSG SGMSG OCT 6412 CR/LF. ASC 4,SEGMENT SNAM1 ASC 3, ASC 3,BREAK OCT 6412 CR/LF. ASC 1,// * PNOBK DEF NOBKM NOBKM ASC 12, BREAKPOINT REMOVED! OCT 6412 CR/LF. ASC 1,// SKP * * * THIS ROUTINE SETS UP BREAKPOINT WITHIN * A SEGMENT * SBRK STA SGA SAVE A & B STB SGB SZB,RSS IF ADDRESS SUPPLIED JMP SBRK0 JSB MPCHK CHECK FOR MP VIOLATION JMP MPMSG STA IADR JSB ADCHK CHECK FOR DBUGR OVERLAP SBRK0 LDB SBNAM COMPUTE BYTE ADDRESS RBL STB BYADD LDB BLKBL FILL WITH BLANKS STB SBNM1 STB SBNM1+1 STB SBNM1+2 * LDA M5 SET CHAR COUNT STA SDTMP SBRK1 JSB SBRK6 READ CHAR CPA "]" CHECK FOR END JMP SBRK3 LDB BYADD STORE CHAR SBT ISZ BYADD ISZ SDTMP NAME COMPLETE JMP SBRK1 NO CONTINUE * SBRK2 JSB SBRK6 IGNOR ALL EXCEPT "]" CPA "]" RSS JMP SBRK2 SBRK3 JSB SBRK6 NOW LOOK FOR ESCAPE,\ OR ^ CPA O176 LDA O33 CPA O33 JSB SBRK5 GO SEND BACKSLASH CPA O134 RSS JMP ERR IF NONE OF ABOVE THEN ERROR JSB SBRK6 NOW LOOK FOR "B" CPA "B" RSS JMP ERR * * NOW WE HAVE GOOD COMMAND * LDA SBNM1 IF NO NAME ASSUME "0" CPA BLKBL RSS CPA ""N" FIX FIRST WORD FOR ALL CLA CPA ""A" OR NONE CCA STA SBNM1 * LDA SBNAM LDB SNAME CMW O3 JMP SBRK4 GO TO NORMAL BREAK NOP LDB SGB WAS ADDRESS SUPPLIED SZB,RSS STB SGA NO,SET ADDRESS TO ZERO FOR JMP LSE SEGMENT BREAK THEN GO GET * NEXT COMMAND * SBRK4 LDA SGA RESTORE A & B LDB SGB JMP BRK AND GO TO NORMAL BREAK * SBRK5 NOP LDA O134 BACKSLASH JSB TYO ECHO LDA O134 LDB TMODE IF SET FOR ESC GOBBLER SZB JSB TYO SEND SECOND BACKSLASH ISZ SBRK5 ADJUST RETURN JMP SBRK5,I M5 OCT -5 ""N" ASC 1,"N * SBRK6 NOP READS CHAR AND CHECKS FOR RUBOUT JSB TTYOP CPA RUB JMP DEL JMP SBRK6,I RUB OCT 177 * ""A" ASC 1,"A SKP * PROC SZB,RSS CLA,INA $P=$1P CMA,INA STA CHC SET PROCEED COUNT LDB DDOT POINT BACK TO STB TRAP LAST ADDRESS LDB BPADR GET THE TRAP ADDRESS CPB TRAP IF RETURNING TO TRAP JMP PR01 SKIP TEST FOR INA,SZA PROCEED COUNT JMP ERR MUST BE 1 FIRST TIME LDA RSS STA SZSKP LDA ALTMI IF SINGLE ESCAPE CPA O1 JMP PRNA OK TO CONTINUE JMP ERR PR01 LDB SKP GET SKIP (SZA OR SZA,RSS) LDA ALTMI IF SINGLE ESCAPE CPA O1 LDB RSS PUT IN UNCONDITIONAL SKIP STB SZSKP PR3 ISZ TRAP STEP OVER THE INTERPITED INSTR. LDB BKIA STB IADR FOR ADRC LDA BIX02 RESTORE JMP IN CASE STA BIX01 2 WORD INSTRUCTION LDA BKIA,I FETCH BROKEN INSTRUCTION JSB AHEAD VALID INSTRUCTION FOR EXECUTION JMP PR5 NO,BACK UP PR1 JSB ADRC CALCULATE REAL ADDRESS JMP MAC NOT ADDRESSABLE: GO TEST FOR MAC GROUP PR0 STA SYMX ACTUAL ADDRESS LDA B RETRIEVE INSTRUCTION AND G74 GET OPCODE CPA G24 IF JMP INSTRUCTION GO JMP TRJMP TEST FOR TRACING CPA JSBI JSB INSTRUCTION? CCB,RSS YES. FAKE IT. JMPI JMP PR2 NOT JSB. LDA SYMX GO GET THE DIRECT ADDRESS JSB DIRA STA OPADD SAVE ADDRESS FOR RETURN CLB,INB CACULATE THE RETURN ADDRESS ADB BKIA STB RTADD SAVE RETURN ADDRESS STB A,I FAKE RETURN ADDRESS INA YES STEP BY ONE TO GET JMP TARGET STA OPADD+1 SAVE TARGET ADDRESS FOR JMP LDB TRAC TRACING? SZB,RSS LDA JSBXQ NO CANGE EFFECTIVE ADDRESS LDB JMPI GET JMP INSTRUCTION JMP PR0 GO SET IT UP PR5 LDA RDWD GET TRACE ADDRESS CPA XE1C EXECUTE MODE? LDA PAC YES STA BKIA RESTORE THE STA IADR ADDRESS JSB CRLF CR LF LDA IADR JSB BRKMS BREAK MESSAGE SKP PR9 JSB PTAB 3 SPACES LDA CH111 I JSB TYO LDA "N" N JSB TYO JMP ERR PR2 IOR DSYMX USING SAVED ADDRESS STA BIX STORE INSTRUCTION PR4 JSB CRLF JSB RSST RESTORE STATUS BIX STA SYMX,I USED TO GET ADDRESS OF SYMX,I BIX01 JMP TRAP,I RETURN TO INTERRUPTED CODE ISZ TRAP INSTRUCTION PERFORMED SKIP BIX02 JMP TRAP,I "N" OCT 116 BKI NOP HOLDS BROKEN INSTRUCTION BKIA DEF SYM ADDRESS OF BROKEN INSTRUCTION JSBI JSB 0 JSBII JSB 0,I * PRNA CPB LIMBO GIVING UP CONTROL? JSB BYE YES, PRINT END MESSAGE JSB CRLF CONTINE JSB RSST JMP DDOT,I * * JSB EXECUTE * JSBXQ DEF *+1 STA ACCA SAVE A REG LDA RTADD STA OPADD,I SET RETURN ADDRESS LDA ACCA RESTORE A REG JMP OPADD+1,I AND EXECUTE JMP * OPADD BSS 2 RTADD BSS 1 SKP * * RESTORE STATUS ROUTINE * RSST NOP LDA BPADR,I SAVE BREAK INSTRUCTION STA BKI LDA LTRAP GET THE TRAP JSB IOR JSBII STA BPADR,I PLANT TRAP * LDB DIDTP RESTORE PROGRAM'S TEMP WORDS STB CRLF TO ITS ID SEGMENT. LDB IDWD1 JSB $LIBR NEED TO GO PRIVILEGED NOP TO DO THIS RESTORE. PR10 LDA CRLF,I RESTORE ID XSA B,I SEGMENT ISZ CRLF WORDS 1 INB TO 5. CPB IDWD6 RSS DONE. JMP PR10 JSB $LIBX LET'S GO DEF *+1 UNPRIVILEGED. DEF *+1 * LDB ACCB RESTORE LDX ACCX MACHINE LDY ACCY STATE LDA FLGBX CLF 1 CLEAR OFLOW O33 SLA,RAR STF 1 TURN IT ON ERA RESTORE E-BIT LDA ACCA JMP RSST,I CH111 OCT 1511 SKP * MAC STA BIX SET INSTRUCTION AND M1100 =B176700 CPA HLT IF A HLT JMP MPMS THEN GO PRINT MP MESSAGE AND M6000 =B172000 CPA HLT IF AN IO INSTRUCTION JMP IO THEN GO CHECK S.C. MAC00 LDA BIX ELSE RESTORE A WITH BIX JSB GET2 2 WORD INSTRUCTION? JMP PR4 NO,GO SET UP INSTRUCTION LDA BKIA YES,SET ADDRESS INA STEP TO MAC ADDRESS RAL,ERA OF SECOND WORD STA BIX01 FOR BIX LDA BIX GET INSTRUCTION CPA JPY JPY? JMP PR6 YES,GO FIX JPY CPA JLY JLY? JMP PR11 YES,GO FIX JLY JMP PR4 NO,GO FINISH THE SET UP PR6 LDY ACCY BE SAFE LDA BIX01 GET 2ND WORD ELA,CLE,ERA ELIMINATE LDA A,I ADDED INDIRECT ADA ACCY FORM DESTINATION ADDRESS JMP PR12 PR11 LDA BKIA SET UP ADA O2 ACTUAL STA ACCY Y LDA BIX01 ELA,CLE,ERA ADA MUPBD TEST FOR DM ERROR SSA,RSS JMP DMCK5 BAD GO PRINT MESSAGE ADA UPBD GOOD SZA,RSS LDA DACCA GET PHONY A REG LDA A,I GET INDIRECT ADDRESS JSB DIRA GET TARGET ADDRESS PR12 LDB TRAC SZB,RSS TRACING? JMP PR2 NO,GO SET UP STA TEMP3 SAVE A JSB CRLF CR LF LDA TEMP3 RESTORE A JMP TRMS SET AND PRINT O2 OCT 2 * IO LDA BIX GET INSTUCTION AND O77 CPA O1 IF S.C. = 1 JMP MAC00 THEN OK JMP MPMS ELSE GO PRINT MP MESSAGE * M1100 OCT 176700 M6000 OCT 172000 SKP * XEC SZB,RSS "EXECUTE" COMMAND JMP ERR LDB TRAP SAVE TRAP INFORMATION STB PAC INCASE WE ARE IN LDB BKIA A BREAK STB ADCK LDB XE1C STB BKIA IF JSB, RETURN TO XE1. STB TRAP OTHERS RETURN TO XE1 JSB AHEAD VALID INSTRUCTION FOR EXECUTION? JMP PR9 NO,NOT ALLOWED STA TEMP2 YES,SAVE INSTRUCTION JSB GET2 2 WORD INSTRUCTION? RSS NO JMP PR9 YES,NOT ALLOWED LDA TEMP2 RESTORE INSTRUCTION JMP XE2 EXECUTE AT BIX * GO SZB,RSS JMP ERR STA TRAP SET ADDRESS LDA BIX02 RESTORE JMP IN CASE STA BIX01 2 WORD INSTRUCTION CLA MAKE A NO-OP XE2 CCB STB CHC PROCEED COUNT=1 JMP PR1 * XE1C DEF XE1 XE1 JMP XE3 NOT SKIP JSB SVST SKIP JSB CRLF RSS * XE3 JSB SVST LDA PAC RESTORE BREAK STA TRAP LDA ADCK CONDITIONS STA BKIA JMP LSE UNL XIF IFN LST PROC JSB BYE SEND BYE MESSAGE JMP .DBUG,I AND EXIT UNL XIF LST HED BREAKPOINT AND TRACE ROUTINES * ADRC NOP GET ADDRESS OF INSTRUCTION LDB A AND G70 CLE,SZA,RSS JMP ADRCX NON-ADDRESSABLE. ISZ ADRC SET SKIP RETURN LDA B AND O2000 PAGE BIT SZA LDA IADR GET PROPER PAGE XOR B AND G76 ADRCX XOR B JMP ADRC,I UNL IFZ LST * * A H E A D * * CHECKS INSTRUCTION ABOUT TO BE EXECUTED TO SEE IF * THE INSTRUCTION IS ALLOWED FOR EXECUTION * * LDA * JSB AHEAD * P+1 * P+2 * AHEAD NOP STA TEMP1 AND DSMSK IF DOUBLE SHIFT CPA ASL JMP AHE02 CPA LSL JMP AHE02 CPA RRL JMP AHE02 * AND M6000 OR IOG CPA HLT JMP AHE02 * AND G70 OR MRG SZA JMP AHE02 * LDA TEMP1 OR SRG OR ASG SSA,RSS JMP AHE02 * ELSE CHECK REST LEGAL OPCODES LDB PNT08 POINT TO START OF TABLE AHE01 CPA B,I GOT A MATCH? JMP AHE02 YES, VALID FOR DDT ADB O3 NO,BUMP POINTER CPB PNT09 DONE? JMP AHEAD,I YES,NOT VALID JMP AHE01 NO,CONTINUE * AHE02 LDA TEMP1 RESTORE INTRUCTION ISZ AHEAD ADJUST RETURN JMP AHEAD,I PNT08 DEF RRL+3 LINK TO START OF REST OF VALID'S PNT09 DEF IVINS LINK TO START OF INVALID INSTR'S SKP * BRKMS NOP PRINT BREAK MESSAGE STA DDOT SAVE THE TRAP ADDRESS LDA SBFLG PRINT SEGMENT BREAK? SZA,RSS JMP BRKM1 CLA STA SBFLG CLEAR FLAG LDB PSGMS PRINT 'SEGMENT NAME0 BREAK' JSB OUTMS MESSAGE BRKM1 LDA DDOT RESTORE A JSB ADRP LDA SRDX JSB TYO ( JSB PTAB A FEW SPACES LDA DDOT,I NOW THE INSTRUCTION JSB INSTP IN SYMBOLIC JSB PTAB PUT IN SOME SPACES LDA SRDX INA JSB TYO ) JSB PTAB MORE SPACES LDA ACCA A REG. JSB BM,I JSB PTAB MORE SPACES LDA ACCB B REG. JSB BM,I JSB PTAB YET MORE SPACES LDA ACCX X REG. JSB BM,I JSB PTAB MORE SPACES LDA ACCY Y REG. JSB BM,I JSB PTAB MORE SPACES LDA FLGBX E,O,INT STA LWT SET LAST WORD TYPED JSB NUMP JMP BRKMS,I UNL XIF LST SKP * SRDX OCT 50 * B Y E * * PRINTS END MESSAGE * BYE NOP STA TEMP5 SAVE A STB TEMP6 SAVE B LDB SBNM1 IS SEGMENT BREAK SET SZB JMP BYE1 YES,DONT PRINT MESSAGE LDB PNT11 ISSUE 'END DBUG' JSB OUTMS MESSAGE. BYE1 LDA TEMP5 RESTORE A LDB TEMP6 RESTORE B JMP BYE,I TEMP5 BSS 1 TEMP6 BSS 1 PNT11 DEF MSG04 MSG04 OCT 6412 ASC 17,END OF DEBUG MODE OCT 6412 CR LF ASC 1,// SKP * ******************************************************************* * * SUBROUTINE OUTMS: * * OUTMS WILL OUTPUT A MESSAGE WHICH TERMINATES WITH A '//' AND * CONTAINS NO INTERNAL /'S. * * CALLING SEQUENCE: * LDB POINTER TO FIRST WORD OF MESSAGE * JSB OUTMS * * RETURN: * ALL REGISTERS ARE DESTROYED. * ******************************************************************* * OUTMS NOP CLA INITIALIZE TO LEFT BYTE STA TEMP1 OF MESSAGE STRING. STB TEMP2 SAVE STRING'S ADDRESS. OTMS1 LDA TEMP2,I GET WORD FROM STRING. LDB TEMP1 GET SLB,RSS APPROPRIATE ALF,ALF BYTE. AND O177 MASK OFF CHARACTER. CPA "/" IF FOUND A "/", THEN END JMP OUTMS,I OF MESSAGE, SO RETURN. JSB TYO OTHERWIZE, PRINT LATEST LDB TEMP1 CHARACTER. SLB IF BYTE COUNT IS ODD, THEN ISZ TEMP2 BUMP WORD POINTER. ISZ TEMP1 INCREMENT BYTE COUNTER JMP OTMS1 AND RETURN FOR MEXT BYTE. SKP UNL IFZ LST * MPCHK NOP MEMORY PROTECT & DM CHECK JSB DMCHK GO RESOLVE INDIRECTS LDB 1775B CHECK FOR MEMORY PROTECT ERROR CMB,INB SUBTRACT FENCE FROM ADB A ADDRESS SSB,RSS IF OK RETURN +1 ISZ MPCHK JMP MPCHK,I ELSE RETURN * DIRA NOP DIRECT ADDRESS TRACK DOWN JSB MPCHK RSS MP ERROR JMP DIRA,I OK RETURN MPMS CCA BACK OUT THE INTERPIT STEP ADA TRAP RESTORE CONDITIONS CPA TRTN TRACING LDA RDWD YES GET TRACE ADDRESS CPA XE1C EXECUTE INSRT? LDA PAC YES RESTORE STA BKIA RESTORE THE ADDRESS STA IADR JSB CRLF RETURN THE CARRAGE LDA IADR JSB BRKMS SEND A BREAK MESSAGE JSB PTAB SEPERATE THE MP? UNL XIF LST MPMSG LDA "M" FETCH AN M JSB TYO PUT IT OUT JMP BADP FOLLOW IT WITH A P? DACCA DEF ACCA POINTER TO A-REG CONTENTS SKP * G E T 2 * * SEARCHES DOUBLE WORD INSTRUCTIONS TABLE TO SEE IF * CURRENT INSTRUCTION IS DEFINED THERE. * * LDA * JSB GET2 * P+1 * P+2 <2 WORD INSTRUCTION,A=SQOZE CODE> * GET2 NOP STA TEMP1 SAVE INSTRUCTION LDB PNT07 POINT TO DOUBLE WORD INSTRUCTIONS MAC02 CPB DSTOP DONE? JMP GET2,I YES,GO FINISH THE SET UP ADB O2 POINT TO OPCODE IN SYMBOL TABLE LDA B,I GET OPCODE CPA TEMP1 DOUBLE WORD INSTRUCTION? JMP MAC01 YES,SET UP FOR 2 WORD INSTRUCTION INB NO,POINT TO NEXT ENTRY JMP MAC02 CONTINUE LOOKING MAC01 ADB M2 POINT BACK TO ENTRY LDA B,I GET SQOZE CODE ISZ GET2 ADJUST RETURN JMP GET2,I DSTOP DEF STTP2 LINK TO END OF 2 WORD INSTR SECTION PNT07 DEF DOUBL LINK TO 2 WORD INSTR SECTION UNL IFZ LST SKP * SVST NOP STX ACCX SAVE STY ACCY REGISTERS STB ACCB STA ACCA CLA ELA,RAL SAVE E-BIT. SOC OVERFLOW ON? INA YES. STA FLGBX LDA BPADR,I SAVE IN CASE OF SEGMENT LOAD STA OLDBK AND MAY WIPE GOOD INSTRUCTION LDA BKI STA BPADR,I RESTORE BROKEN INSTRUCTION LDA BPADR STA BKIA WHERE BROKEN INSTRUCTION WAS STA IADR FOR PRINT LDA BIXS RESTORE THE DOUBLE WORD INSTRUCTION SZA IF NOT SET UP SKIP STA BIX01 LDA BIX01 SET UP STA BIXS * LDB DIDTP SAVE PROGRAM'S TEMP WORDS STB CRLF FROM ITS ID SEGMENT. LDB IDWD1 SVST5 XLA B,I SAVE ID STA CRLF,I SEGMENT'S ISZ CRLF WORDS 1 INB TO 5. CPB IDWD6 JMP SVST,I DONE! JMP SVST5 BIXS NOP HOLDS COPY OF 2ND WORD BEFORE RETURN IDWD1 EQU 1721B ID SEGMENT WORD 1 IDWD6 EQU 1726B ID SEGMENT WORD 6 DIDTP DEF IDTMP POINTER TO BUFFER FOR SAVING IDTMP BSS 5 ID SEGMENT'S TEMP WORDS. UNL XIF LST UNL IFZ LST HED TRACE ROUTINE TRACE SZB,RSS MAKE A ZERO CLA,INA INTO A 1 CMA,INA SET NEG FOR STA TRAC COUNT AND SET TRNX LDA DDOT STA IADR JSB ADCHK CHECK FOR DBUGR OVERLAP STA RDWD SAVE TRAP LOCATION STA BKIA SET FOR PROCEED LDA TRTN SET RETURN ADDRESS STA TRAP CCA SET PROCEED COUNT FOR STA CHC POSSIBLE JSB TEST JMP PR3 GO EXECUTE THE INSTRUCTION TRTN DEF * RETURN DEFINATION RSS NO SKIP ISZ RDWD SKIP STEP THE ADDRESS ISZ RDWD TWO TIMES IF SKIP JSB SVST SAVE THE STATE LDA RDWD GET THE NEW ADDRESS TRMS STA BKIA RESTORE CONDITIONS STA IADR SET ADDRESS FOR PRINT JSB BRKMS WRITE THE BREAK MESSAGE ISZ TRAC END OF TRACE? JMP TRNX NO CONTINUE JSB PTAB 3 SPACES JMP LSF YES GO GET NEXT COMMAND. * TRJMP LDB TRAC TRACING? SZB,RSS JMP PR2 NO GO SET UP JSB CRLF SEND CARRAGE RETURN LINEFEED LDA SYMX YES JUST UP DATE JSB DIRA THE ADDRESS (MAKE DIRECT) JMP TRMS GO SET AND PRINT UNL XIF LST HED SEARCH ROUTINES * EAS LDA CSKP STA WSD WDS LDA CSZA CH130 CLE,SSA,SLA ALWAYS SKIPS * NWS LDA CSNZA SZB,RSS JMP ERR STA WSTST JSB CRLF LDA LL STA IADR WSL JSB ADCK SEE IF DONE JMP WSIDX IN DEBUG, IGNORE UNL IFZ LST LDA IADR,I UNL XIF IFN LST JSB IGET GET WORD FROM DUMP DEF *+2 DEF IADR UNL XIF LST WSD NOP SKIP IF EFFECTIVE ADDR. JMP WSC * JSB ADRC JMP WSIDX NOT ADDRESSABLE. JSB DMCK GO RESOLVE INDIRECTS JMP WSIDX TOO MANY INDIRECTS NOP DM ERROR * WSC XOR WRD AND MSK WSTST NOP SZA OR SZA,RSS JMP WSIDX JSB PAC PRINT ADDRESS AND CONTENTS JSB CRLF WSIDX ISZ IADR JMP WSL * * * DM AND MULTIPLE INDIRECT CHECK * * INPUT: A REG=INDIRECT ADDRESS * * OUTPUT: A REG=DIRECT ADDRESS * B REG=ACCB * DMCHK NOP JSB DMCK JMP DMCK3 GO PRINT INDIRECT ERROR JMP DMCK4 GO PRINT DM ERROR JMP DMCHK,I RETURN * * LDA ADDR * JSB DMCK * * * * * OUTPUT: A REG=DIRECT ADDRESS * B REG=ACCB * DMCK NOP LDB M20 SET UP INDIRECT COUNT STB DMCNT LDB ACCB SET UP B REG JMP DMCK1 GO TEST ADDRESS * DMCK0 ISZ DMCNT RSS JMP DMCK,I YES,ERROR 1 RETURN * SZA,RSS TRYING TO USE A REG LDA DACCA YES,GET PHONY A REG ADA MUPBD TEST FOR UPPER BOUND SSA,RSS (DM ERROR) JMP DMCK2 ERROR RETURN ADA UPBD GOOD THEN CORRECT A STA DMCKT JSB IGET DEF *+2 DEF DMCKT DMCK1 RAL,CLE,SLA,ERA IS IT IN DIRECT? JMP DMCK0 YES,GO GET NEXT LEVEL ADA MUPBD NO,CHECK FOR DM ERROR SSA ISZ DMCK BUMP ONE MORE FOR GOOD DMCK2 ADA UPBD RESTORE A REG ISZ DMCK JMP DMCK,I * "I" OCT 111 DMCKT NOP M20 OCT -20 DMCNT BSS 1 * DMCK3 LDA "I" JSB TYO PRINT "I?" JMP ERR * * DMCK5 ADA UPBD RESTORE A DMCK4 JSB NUMP PRINT DM? ERROR DMCK6 JSB PTAB SEPARATE "DM?" LDA "D" JSB TYO TYPE "DM?" LDA "M" JSB TYO JMP ERR * "D" OCT 104 MUPBD BSS 1 NEGATIVE OF UPPER BOUND UPBD BSS 1 POSITIVE BOUND * PAC NOP LDA IADR PRINT ADDRESS AND CONTENTS JSB ADRP JSB TYO PRINT / JSB PTAB JSB IGET GET THE WORD FROM THE DUMP DEF *+2 DEF IADR JSB PM,I JMP PAC,I UNL IFZ LST SKP * * CLEAR CORE * ZRO LDB ALTMI ADB M2 SSB JMP ERR LDB LL STB IADR LDA WRD ZROL JSB ADCHK STA IADR,I ISZ IADR JMP ZROL * UNL XIF LST ADCK NOP CHECK FOR DEBUG OVERLAP STA PR SAVE AC LDA IADR CMA,INA ADA UL CH56 OCT 1256 SSA=RAL,SLA. CLEARS E JMP SOXA DONE, GO RESET LDA IADR CH40 CMA,SEZ E CLEAR: WILL SKIP G70 OCT 70000 LDB A UNL IFZ LST ADA STEND SSA,RSS UNL XIF LST JMP ADCKR BELOW DEBUG ADB DEBOP SSB,RSS JMP ADCKO IN DEBUG, LOSE LDA IADR TEST IF IN PARTITION JSB DMCHK ADCKR ISZ ADCK BUMP FOR NORMAL RETURN ADCKO LDA PR RESTORE AC JMP ADCK,I RETURN * UNL IFZ LST ADCHK NOP JSB ADCK CH53 OCT 1053 RSS=ALS,SLA JMP ADCHK,I JSB PTAB 3 SPACES LDA "T" JSB TYO T JMP BADP "T" OCT 124 HED TAPE OPERATIONS * TABL JSB SOI TABL1 JSB RWDB STA SYM JSB RWDB STA SYM+R AND G70 STA ADCK SAVE FLAGS XOR SYM+R DELETE FLAGS STA SYM+R JSB RWDB LDB ADCK BLF ADB RELTB ADA B,I RELOCATE SYMBOL JSB DEFS JMP TABL1 * LOAD JSB SOI LOA JSB RWDB JSB ADCHK IS ADDRESS OK STA IADR,I STORE JMP LOA * VFY JSB CRLF JSB SOI LDV JSB RWDB JSB ADCK NOP CPA IADR,I COMPARE JMP LDV STORE DONE OR CORE MATCH. SZA,RSS JMP LDV IGNORE ZERO ON TAPE. STA RWDB SAVE TAPE WORD. JSB PAC PRINT DISCREPANCY. JSB PTAB LDA RWDB JSB PM,I JSB CRLF JMP LDV RELTB DEF WRD-1 SKP * SOI NOP LDB SOI INB STB RWDB SOF JSB RDCH INB,SZB,RSS COUNT BLANK TAPE JMP SOX LOTS: END OF FILE. C3007 CMA,INA,SZA,RSS HAVE WE A WORD COUNT? JMP SOF NOT YET. STA CHC JSB RDCH DISCARD ONE FRAME JSB RDWD BLOCK ADDRESS STA CHI INIT CHECKSUM ELA,CLE,ERA MAKE SURE NOT INDIRECT STA IADR * RWDG JSB RDWD LDB A ADB CHI STB CHI JMP RWDB,I RETURN * RWDB NOP ISZ IADR ISZ CHC INDEX WORDCOUNT JMP RWDG JSB RDWD READ CHECKSUM LDB M6 MAX. RECORD GAP CPA CHI JMP SOF CKSM OK, GO TO NEXT RECORD LDA RDCHK BAD CHECKSUM LDB SRDX JSB PN COMPLAIN SOX EQU * UNL XIF LST SOXA LDA LOCP,I STA IADR JMP LSE SKP * UNL IFZ LST RDWD NOP READ A WORD JSB RDCH ALF,ALF STA CH JSB RDCH ADA CH JMP RDWD,I * RDCH NOP READ A CHARACTER STB BS SAVE B JSB EXEC GO TO EXEC FOR ONE CHAR. ON 5 DEF RDRTN DEF O1 DEF O2105 DEF BF DEF M1 RDRTN LDA BF GET THE CHAR ALF,ALF AND O377 LDB BS RESTORE B JMP RDCH,I O2105 OCT 2105 O377 OCT 377 RDCHK OCT 50245 SKP PNCH JSB STORE LDA LFLG SZA JMP PCH1 LIMITS SPECIFIED LDA IADR USE CURRENT REGISTER STA LL STA UL PCH1 LDA LL CMA,INA ADA UL SSA JMP LSE DONE AND O77 CMA STA CHC WORDS THIS BLOCK CMA,CCE,INA ALF,ALF JSB PWD WORD COUNT LDA LL STA CHI CHECKSUM JSB PWD ORIGIN PCHL LDA LL,I JSB PWD ADA CHI STA CHI ISZ LL ISZ CHC JMP PCHL JSB PWD CHECKSUM CLA JSB PWD BLANK FRAMES JSB PWD FOR INTER-RECORD GAP JMP PCH1 * PWD NOP PUNCH A WORD STA BF SET WORD JSB EXEC GO TO PUNCH WITH ONE WORD DEF PWRTN DEF O2 DEF O2104 HONEST BINARY DEF BF DEF O1 PWRTN LDA BF RESTORE A JMP PWD,I O2104 OCT 2104 UNL XIF LST HED SYMBOL TABLE OPERATIONS * DEFS NOP STA RDCH JSB EVS JMP DRDF DEFS1 LDA START CHECK FOR OVER FLOW CMA,INA ADA STEND SSA JMP SYMO OVERFLOW GO BITCH CCB NAKE NEW ENTRY ADB STEND LDA RDCH STA B,I ADB M1 LDA SYM+R STA B,I LDA SYM SSA ADA C1031 ADA M3100 SSA,RSS ADB M1 LDA SYM STA B,I STB STEND JMP DEFS,I * DRDF SEZ,RSS IF IN OTHER TABLE JMP DEFS1 PRETEND IT WASN'T * LDA RDCH FIX OLD ENTRY STA CH,I JMP DEFS,I START DEF END+4 SKP * EVS NOP LDB SYM IS IT A CLE CPB CLE JMP CLEFD YES GO SET CLE FLAG LDA STEND STA CH EVSL LDA CH CPA STTOP JMP EVSU UNDEFINED. LDB CH,I GET LEFT HALF ISZ CH G74 STB A USED AS CONSTANT SSB ADB C1031 OVERFLOW. ADB M3100 CPA SYM JMP EVSM1 LEFT HALF MATCH. SSB,RSS ISZ CH EVSI ISZ CH JMP EVSL TRY AGAIN. * EVSM1 LDA CH,I SSB CLA,RSS ISZ CH CPA SYM+R JMP EVSF RIGHT HALF MATCHES. JMP EVSI * EVSF LDA CMFLG HAS A COMMA BEEN TYPED CLE,SZA,RSS JMP EVSF2 THEN VALUE IS OK LDA ISEXP YES MAKE SURE NOT CMA,INA FIRST ROTATE ADA CH CLE,SSA BELOW ROTATES JMP EVSF2 YES THEN OK ADA M60 CLE,SSA ABOVE FIRST ROTATES JMP EVSI NO THEN CONTINUE JMP EVSF2 YES RETURN * * EVSU JSB FLUSH NOT IN OUR TABLE SO BLOW JSB SYMP THE SYMBOL JSB PTAB JSB PTAB CLA STA CCO AND GO TO THE MAIN FOR SNAP VALUE JSB FNDET CALL THE MAIN ROUTINE DEF *+6 DEF BF PASS THE NAME DEF ERRF AN ERROR FLAG DCB NOP THE DCB ADDRESS DEF SYTP EXPECT THE SYMBOL TYPE HERE (MUST BE ZERO) DEF VALUE VALUE COMES HERE LDA ERRF IF FILE ERROR SSA,RSS THEN NO SYMBOL CLA,INA CPA SYTP TYPE MUST BE ONE RSS OK?? ISZ EVS NO SET ERROR RETURN LDA VALUE PICK UP VALUE RETURNED CLE,RSS SKIP OVER THE LOCAL PICK UP EVSF2 LDA CH,I PICK UP VALUE JMP EVS,I * M60 OCT -60 CLEFD STB CLEFG SET CLE FLAG CLA,CLE SET VALUE TO ZERO JMP EVS,I * CMFLG OCT 0 VALUE NOP SYTP NOP ERRF NOP CLEFG OCT 0 O40 OCT 40 ISL3I DEF ISL3 M3100 OCT -3100 C1031 CLF 0 STTOP DEF STTP LINK TO END OF SYMBOL TABLE SKP * * SYMBOL TABLE SEARCH * SRCST NOP STA CH SAVE TABLE LIMITS STB TYO LDA C1000 STA DNM STA NUMP SRCL LDB CH CPB TYO JMP SRCST,I DONE, RETURN LDA CH,I SSA ADA C1031 ADA M3100 CLE,SSA,RSS ISZ CH ISZ CH LDA CH,I FETCH SYMBOL VALUE CH45 CMA,SEZ,INA,RSS WON'T SKIP ADA ONM COMPARE SEZ,CLE,RSS JMP SRCI ENTRY TOO BIG, LOSE STA PR LDA B IF >2 CARACTERS INA CPA CH RSS JMP SRCI1 THEN LOOSE LDA PR YES TEST VALUE ADA NUMP CCE,SSA,RSS JMP SRCI1 AS GOOD OR BETTER ALREADY CH44 CMA,SEZ,INA GOOD MATCH (WON'T SKIP) ADA NUMP STA NUMP UPDATE CLOSENESS LDA B,I SAVE SYMBOL STA SYMP SKP SRCI1 LDA PR CHECK IF BETTER ADA DNM THAN LAST ONE CMA,SSA,INA JMP SRCI NO FORGET IT CLA CLEAR TEMP ",C" FLAG STA CMACT LDA TYO IF SEARCH OF USER TABLE CPA ISEND THEN JMP SRCI2 SKIP LDA C1000 CLEAR SINGLE DEF IF OP-CODE STA NUMP LDA CH,I GET THE VALUE AND ONM MASK CPA CH,I MUST HAVE ALL THE DEFINED RSS BITS ELSE JMP SRCI FORGET SYMBOL SSA IF MAC GROUP GO CHANGE OFFSET JMP SRCI4 XOR ONM OR NOT SAME GROUP AND O6000 SZA JMP SRCI FORGET SYMBOL LDA B,I IF A CPA SEZ SEZ, JMP SRCI3 CPA SLA SLA, JMP SRCI3 CPA SLB OR SLB JMP SRCI3 THEN STOP SEARCH SRCI2 LDA PR OK UPDATE CMA,INA STA DNM LDA CMACT ",C" FLAG STA CMAC LDA B,I AND SAVE THE STA SYM THE SYMBOL INB LDA B,I CPB CH CLA STA SYM+R SRCI ISZ CH JMP SRCL * SRCI3 LDA CH SET END TO NEXT POINTER INA STA TYO JMP SRCI2 AND CONTINUE * SRCI4 AND DSMSK IF DOUBLE SHIFT CPA ASL GO ALLOW O17 OFFSET JMP SRCI8 CPA LSL JMP SRCI8 CPA RRL JMP SRCI8 CPA STF IF STF DONT STRIP C BIT JMP SRCI7 AND O2000 SZA JMP SRCI6 IF NOT IO GROUP * SRCI5 CMA MUST BE EXACT ADA PR SSA,RSS IS IT WITHIN LIMITS JMP SRCI NO FORGET IT LDA CH40 SET TERMINATOR TO SPACE STA TERM JMP SRCI2 * SRCI6 LDA ONM AND O1000 SET ",C" FLAG STA CMACT IN TEMP VALUE XOR PR REMOVE THE CLEAR FLAG BIT STA PR * SRCI7 LDA O77 JMP SRCI5 * SRCI8 LDA O17 JMP SRCI5 DSMSK OCT 176760 CMAC OCT 0 CMACT OCT 0 TERM OCT 54 O17 OCT 17 C1000 OCT 100000 HED PRINT ROUTINES * ADRP NOP PRINT ADDRESS IN SYMBOLIC STA ASCP ELA,CLE,ERA GET DIRECT ADDRESS STA ONM LDA STEND USER'S SYMBOL AREA LDB ISEND JSB ADRSP OCT 10 LIMIT OFFSET TO 10 LDA ASCP SSA,RSS INDIRECT? JMP ADRPX NO, DONE. LDA CH54 , JSB TYO LDA CH111 I JSB TYO ADRPX LDA CH57 JMP ADRP,I * ADRSP NOP PRINT SYMBOLIC EXPRESSION JSB SRCST SEARCH PART OF SYMBOL TABLE LDA ONM LDB ADRSP,I ISZ ADRSP STEP RETURN ADB DNM CLOSE ENOUGH? SSB,RSS JMP PSYM YES PRINT ABSOLUTE. LDB SYMP GET SINGLE SYMBOL STB SYM AND SET CLB IT UP STB SYM+R LDB NUMP SET VALUE STB DNM CPB C1000 IF NOT DEFINED JMP AABS FORGET IT. PSYM JSB SYMP PRINT BEST SYMBOL LDA DNM SZA,RSS EXACT? JMP PCMAC YES, GO CHECK ",C" LDA CH53 + LDB ADRSP IF INSTRUCTION CPB DINRT THEN LDA TERM PRINT "," OR " " INSTEAD JSB TYO LDB DNM PRINT DIFFERENCE CMB,INB LDA ADRSP GET RETURN ADDRESS CPA DINRT PRINTING NON ADDRESSABLE INSTR? JMP INONB YES GO RECURE AABSS STB A NO SET OFFSET IN A AABS JSB NUMP PCMAC LDA CMAC IS ",C" REQUIRED SZA,RSS JMP ADRSP,I NO, THEN RETURN LDA CH54 JSB TYO PRINT ",C" LDA CH103 JSB TYO CLA CLEAR ",C" FLAG STA CMAC JMP ADRSP,I AND RETURN CH103 OCT 103 DINRT DEF INONC SKP * I N S T P * * PRINT SYMBOLIC INSTRUCTION * * LDA * JSB INSTP * INSTP NOP JSB ADRC MRG INSTRUCTION? JMP INOND NO,SEE IF 2 WORD INSTRUCTION STA DNM SAVE REFERENCED ADDRESS LDA B AND G74 GET OPCODE ALF,RAL TO LOW BITS ADA OPPTR INDEX INTO MRG SYMBOL TABLE LDA A,I FETCH OPTAB ENTRY LDB SRDX JSB PN PRINT IT INONE LDA CH40 SPACE JSB TYO LDA DNM FETCH ADDRESS JSB ADRP PRINT ADDRESS JMP INSTP,I INONB LDA ONM SSA IF MAC GROUP JMP AABSS JUST PRINT IT AND O6000 ISOLATE THE GROUP BIT ADB A ADD IT BACK STB ONM NON-ADDRESSABLE. INONA LDA CH54 SET TERMINATOR TO "," STA TERM LDA ISEXP POINT TO LDB STTOP TABLE "ISL2" JSB ADRSP SEARCH INSTRUCTION OCT 1777 INONC JMP INSTP,I INOND STB ONM SAVE INSTRUCTION JSB GET2 2 WORD INSTRUCTION? JMP INONA NO,NON-ADDRESSABLE LDB SRDX YES JSB PN PRINT IT LDA TRAC SZA,RSS TRACING? JMP INSTP,I NO,DON'T PRINT ADDRESS LDA DDOT POINT TO INSRUCTION'S INA ADDRESS PARAMETER LDA A,I GET ADDRESS STA DNM SAVE IT JMP INONE ISEXP DEF ISL2 O6000 OCT 6000 SKP * ENDT EQU * CRLF NOP LDA O15 JSB TYO LDA O12 JSB TYO JMP CRLF,I * END1 BSS 0 PTAB NOP LDA CH40 SPACE JSB TYO LDA CH40 JSB TYO LDA CH40 JSB TYO JMP PTAB,I * ASCP NOP ASCII PRINT STA SYMP ALF,ALF JSB TYO LDA SYMP JSB TYO LDA CH42 ADD A " JSB TYO JMP ASCP,I * SYMP NOP SYMBOL PRINT LDA SYM LDB SRDX JSB PN LDA SYM+R LDB SRDX SZA JSB PN JMP SYMP,I * NUMP NOP NUMBER PRINT LDB RADIX JSB PN LDA CH56 PRINT . LDB RADIX CPB O12 IF DECIMAL. JSB TYO JMP NUMP,I HED NUMBER AND SYMBOL PRINT * PN NOP A=NUMBER, B=RADIX. STA PNTM STB PNT3 CMB,INB STB PNT2 CLB ENTER: B = NUMBER. PDNC STB ENDT LDB PNTM PDVD STB END1 LDA M20 STA CH CLA PDVL CLE,ELB LONG LEFT SHIFT. ELA ADA PNT2 TRIAL DIVIDE SSA,RSS GOES? INB,RSS YES, BUMP QUOTENT ADA PNT3 NO, RESTORE ISZ CH ROUND AND ROUND... JMP PDVL WE GO. CPB ENDT QUOTIENT IN B, REM IN A. JMP PDPNT JMP PDVD DIVIDE AGAIN. PDPNT LDB PNT3 CPB SRDX ADA M1 ADA M12 SSA SKIP IF LETTER ADA M7 NUMBER FIXUP ADA O101 CONVERT TO ASCII CPA O133 PERIOD? LDA CH56 YES. CPA O134 $ ? LDA CH44 YES. CPA O135 % ? LDA CH45 YES. JSB TYO LDB END1 CPB PNTM JMP PN,I JMP PDNC M7 OCT -7 PNTM NOP PNT2 NOP PNT3 NOP M12 OCT -12 O133 OCT 133 O135 OCT 135 UNL IFN LST M6000 OCT 172000 O2 OCT 2 RDCH NOP RDWD NOP CH53 OCT 1053 CH111 OCT 1511 SKP UNL XIF LST TYO NOP AND O177 ISOLATE THE CHARACTER STA TTYOP SAVE CHAR. TO BE OUTPUT LDB CCO GET CURRENT CHARACTER COUNT CLE,ERB ADJUST TO WORD OFFSET ADB DBF ADD THE BUFFER ADDRESS SEZ,RSS IF HIGH CHAR. ALF,SLA,ALF ROTATE AND SKIP IOR B,I ELSE ADD IN THE HIGH FORM LAST TIME STA B,I SAVE THE CHAR ISZ CCO STEP THE COUNT LDB TTYOP IF LINE FEED CPB O12 JSB FLUSH FLUSH THE BUFFER LDB CCO IF BUFFER FULL CPB MAXBF THEN JSB FLUSH FLUSH IT LDB ACCB SET B REG FOR RETURN JMP TYO,I RETURN * FLUSH NOP JSB IFBRK CHECK FOR BREAK DEF *+1 SZA IF ONE JMP LSE TERMINATE CURRENT OP LDA CCO GET COUNT CMA,INA,SZA,RSS IF ZERO JMP FLUSH,I EXIT STA CCO SET CHARACTER COUNT JSB EXEC WRITE THE LINE ON THE TTY DEF RTN01 DEF O2 DEF LU HONEST MODE BINARY DBF DEF BF DEF CCO RTN01 CLA CLEAR THE CHAR. STA CCO COUNT JMP FLUSH,I RETURN SKP * TTYOP NOP JSB FLUSH FLUSH ANY PENDING OUTPUT JSB $LIBR DO INPUT AS DEF TDB REENTRENT JSB EXEC GET ONE CHAR DEF RTN02 DEF O1 FROM SYS TY DEF LU HONEST BINARY ECHO DEF BF DEF M1 ONE CHARACTER RTN02 LDA BF PUT CHAR ALF,ALF IN LOW AND O177 A AND MASK IT LDB TTYOP GET THE RETURN ADDRESS STB TDBRT SET FOR EXIT JSB $LIBX EXIT BACK DEF TDB TO THE CALLER NOP * TDB NOP TDB FOR REENTRENT DEC 4 FOUR WORDS TDBRT NOP RETURN ADDRESS BF NOP BSS 35 MAX BUFFER IS 72 CHAR MAXBF ABS *-BF+*-BF CCO NOP BS NOP HED CONSTANTS,POINTERS,TABLES & VARIABLES OPTAB OCT 115002 NOP - 0 OCT 3 OCT 44216 AND - 10 OCT 100624 JSB - 14 OCT 154204 XOR - 20 OCT 100262 JMP - 24 OCT 75304 IOR - 30 OCT 75554 ISZ - 34 OCT 43373 ADA - 40 OCT 43374 ADB - 44 OCT 52533 CPA - 50 OCT 52534 CPB - 54 OCT 105673 LDA - 60 OCT 105674 LDB - 64 OCT 134773 STA - 70 OCT 134774 STB - 74 OCT 0 DUMMY ADDRESS FOR LOADR SKP M1 OCT -1 M6 OCT -6 O1 OCT 1 O12 OCT 12 O77 OCT 77 O101 OCT 101 "A" EQU O101 O134 OCT 134 O177 OCT 177 TRAC NOP TRACING FLAG WRD NOP LL NOP UL NOP LU OCT 2501 ACCA NOP ACCB NOP CH NOP CHI NOP SYMXI DEF SYM SYMX NOP SYM OCT 0,0 ONM NOP DNM NOP CHC NOP ALTMI NOP LFLG NOP LIMBO EQU SYMXI IADR NOP RADIX OCT 10 PM DEF INSTP ISEND DEF ISL LOCP DEF LOC STED DEF STEND OPPTR DEF OPTAB ADRPP DEF ADRP MASTER MODE TABLE - MODE INSPP DEF INSTP IS SET BY INDEXING INTO NUMPP DEF NUMP THIS TABLE AND PICKING ASCPP DEF ASCP UP POINTER FOR DISPATCHING * DEBOP DEF *+1 FIRST WORD WICH CAN BE MODIFIED * CEND OCT 77777 DO NOT MOVE DEF END THESE VALUES!!!!!!!!!!!!!!!!!! STEND DEF ISL "F" MSK OCT 177777 "M" FLGBX NOP "M+1" O,E AND INTERRUPT STATUS BPADR DEF SYM "M+2" BP ADDRESS 2 ACCX NOP "M+3" CONTENTS OF X REGISTER ACCY NOP "M+4" CONTENTS OF Y REGISTER BVAL NOP "M+5" BREAKPOINT COMPARE VALUE BMSK OCT 177777 "M+6" BREAKPOINT MASK BADD NOP "M+7" REG OR MEMORY TO BE TESTED SKP SZA "M+8" SENSE OF TEST SZA =,SZA,RSS /= UNL IFZ LST LTRAP DEF $TRAP ORB PLANT A DEF ON THE BASE PAGE $TRAP DEF TRAP ORR ONLY NEED ONE WORD * * UNL XIF LST END ASMB,R,Q,C,Z * * **************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * **************************************************************** * * THE Z OPTION OF WHZAT IS THE CRASH DUMP VERSION * IN THAT VERSION ALL MEMORY REFERENCES ARE TO BE * THROUGH EXTERNAL ROUTINES WHICH ACCESS THE DUMP * * THE N OPTION IS THE RTE-IV VERSION * IFN HED WHZAT FOR RTE-IV NAM WHZAT,1,1 92067-16007 REV.GAGA 790316 XIF IFZ HED WHZAT FOR CRASH DUMP OF RTE-IV NAM WHZIT,7 92067-16??? REV .GAGA 790316 XIF * * NAME: WHZAT * SOURCE: 92067-18007 * RELOC: 92067-16007 * PRGMR: E.J.W. * SUP PRESS ALL EXTRANEOUS LISTING EXT EXEC,TMVAL EXT .MWF,.XLA,.XLB IFN EXT $MATA,$MNP,$TIME,$RNTB,$CLAS * * EQTA EQU 1650B EQT# EQU 1651B DRT EQU 1652B LUMAX EQU 1653B KEYWD EQU 1657B XEQT EQU 1717B * XIF * A EQU 0 B EQU 1 * *THE FOLLOWING IS A SAMPLE OUTPUT OF THIS PROGRAM: * ON,WHZAT,LU * * 09:51:50:710 * ********************************************************************** * PT SZ PRGRM,T ,PRIOR*DRMT*SCHD*I/O *WAIT*MEMY*DISC*OPER * NEXT TIME * * ********************************************************************** * 0 ** MEM *1 *09000 ***** 1 * 2 2 R$PN$*1 *00010 *************** 3,CL 032 * 3 5 PROGA*3 *00097 ******************************* 6 * 4 5 PROGB*3 *00097B*************** 3,LULK 40,LKPRG=PROGA * 5 17 PROGC*3E*00097 *************** 3,RN 031,LKPRG=PROGD * 3A27 PROGD*4 *00097 *************** 3,RESOURCE * 5 7 PROGE*3 *00097 *************** 3,CLASS # * 2 4 QUIKR*3 *00099 0 **********************************00:00:00:000 * 6 7 FMGR *3 *00090 *************** 3,EDITR'S QUEUE * 3 7 EDITR*3 *00050 ************************* 5 * 6 15 ASMB *3 *00099 *************** 3,LU,EQ DN , 5(0[00000000]) * 4A 6 TIMEL*4 *00090 *************** 3,LU,EQ DN 6, 5(0[00000000]) * 4A 6 TIMEL*4 *00090 *************** 3,LU,EQ DN *********00:00:00:000 * 7 7 FMG07*3 *00050 *************** 3,BL,EQT 7 * 2 3 WHZAT*4 *00001 ***** 1 * 0 ** RENSB*1 *00060 ******************** 4 * 3 6 PROGF*4 *00096 *************** 3,RN 031,LKPRG=GLOBL * 6 7 ED26 *3 *00050 ********** 2, 16(2[00000010]) * ********************************************************************** * DOWN LU'S, 6, 14 ************************************************************************ * DOWN EQT'S, 5, 6 * ********************************************************************** * 09:51:50:710 * * * BRIEF EXPLANATION OF SOME OF THE ABOVE. * * PT SZ COLUMN HEADING (PARTITION NUMBER AND PARTITION SIZE) * 0 ** IN RTE-IV MEANS MEMORY RESIDENT PROGRAM * 5 8 IN RTE-IV MEANS PARTITION #5 IS USED AND 8 PAGES IN USE * 11 IN RTE-IV MEANS SCHEDULED PROGRAM IS NOT YET IN PARTITION * * 'A' AFTER THE PARTITION # MEANS THE PROGRAM WAS ASSIGNED * 'E' AFTER THE PROGRAM'S TYPE MEANS IT IS AN EMA PROGRAM * 'B' AFTER THE PROGRAM'S PRIORITY MEANS RUNNING UNDER BATCH * WHEN A PROGRAM IS IN STATE 3[WAIT],THE REASON FOR BEING IN THAT * STATE WILL BE SPECIFIED ACCORDING TO THE FOLLOWING RULES : * IDSEG(2) ::= $RNTB => 'RN ALLOCATION' * ::= DRT(#[6:10])=RN# => 'LU # LOCKED' * ::= >$RNTB,<$RNTB+[$RNTB] => 'RN LOCKED' * ::= $CLAS => 'CLASS ALLOCATION' * ::= >$CLAS,<$CLAS+[$CLAS] => 'CLASS GET' * ::= 4 => 'DEVICE(LU OR EQT) DOWN' * ::= SON'S IDSEG ADDRESS => 'SON'S NAME' * ::= EQT ADDRESS => 'BL,EQT#NN' * * * * FORMAT IF THE PARTITION LIST OPTION IS CHOSEN IN RTE-IV * ON,WHZAT,LU,1 * * 09:00:21:250 * ********************************************************************** * PTN# SIZE PAGES BG/RT PRGRM * ********************************************************************** * 1 7 42- 48 BG FMG11 * 2 15 49- 63 BG EDITR * 3 16 64- 79 RT WHZAT * 4M 48 80- 127 BG EMAPR * 5C 16 80- 95 BG * 6C 16 96- 111 BG * 7C 16 112- 127 BG * 8M 64 128- 191 RT * 9SR 16 128- 143 RT * 10S 16 144- 159 RT PROGQ * 11S 16 160- 175 RT SAMPL * 12SR 16 176- 191 RT * 13 R 64 192- 255 BG EMAID * 14 * 15 * ********************************************************************** * 09:00:21:310 * * SKP IFN WHAT JSB .XLA B,I DEF B,I CLE,SZA,RSS SCHED W PRAM ? CLA,CCE,INA NO-DEFAULT TO LU 1 STA CRTLU SAVE LU FOR OUTPUT INB JSB .XLA B,I DEF B,I STA PARM2 SAVE SECOND PARAMETER INB JSB .XLA B,I GET SPECIAL LU PARAM DEF B,I SZA,RSS IN CASE OF PREV RUN LDA CRTLU SEZ DEFAULT NEEDED? STA CRTLU YES INB PICK UP THE JSB .XLB B,I SESID FROM LAST TIME DEF B,I STB SESID AND SAVE FOR NOW IF NEEDED SPC 2 LDA .EOF SEND BLANK LINE LDB DM6 JSB PRINT USE STD PRINT SUB JSB TOD PRINT TIME-OF-DAY AS NEXT LINE JSB STARS ERASE EOL + A LINE OF ASTERISKS * LDA PARM2 XIF IFZ * * THE DUMP ANAL. VERSION MUST USE THE DUMP ANAL. EXTS TO * GET THE KEY SYSTEM ADDRESSES * EXT .ENTR,FNDET ENT WHZIT * TBLCO DEC -5 * * DEFINE SOME SYMBOLS TO KEEP ASMB HAPPY * WHAT EQU 0 $MATA EQU 0 $MNP EQU 0 $TIME EQU 0 $RNTB EQU 0 $CLAS EQU 0 DDTBL DEF *+1 SYMBOL TABLE ADDRESS ASC 3,$MATA ASC 3,$MNP ASC 3,$TIME ASC 3,$RNTB ASC 3,$CLAS * DNMAD DEF *+1,I ADDRESS OF NAME DEFS LIST DEF @MATA DEF @MNP DEF @TIME DEF .RNTB DEF .CLAS * * EQTA NOP EQT# NOP DRT NOP LUMAX NOP KEYWD NOP XEQT NOP * COU NOP ERR NOP TYP NOP * LU NOP DCB NOP DCB FOR THE FIND ENT CALLS FLPRM NOP WHZIT NOP JSB .ENTR GET THE PRAMS DEF LU LDA DDTBL STA DSYM1 LDA DNMAD GET THE DEF TO THE DEFS STA DSYM AND SET IT IN THE CALL LDA TBLCO GET THE COUNTER STA COU AND SET THE COUNT * * * FIRST LOOK UP ALL THE REQUIRED ADDRESSES * MOR JSB FNDET CALL THE DUMP ROUTINE TO GET THEM DEF *+6 DSYM1 NOP DEF ERR DEF DCB,I DEF TYP DSYM NOP LDA DSYM1 ADA D3 STEP THE ADDRESSES STA DSYM1 ISZ DSYM STEP THE POINTER ISZ COU DONE? JMP MOR NO GO DO MORE * * NOW THE BASE PAGE STUFF * JSB .XLA EQTA EQT ADDRESSES DEF 1650B STA EQTA SET THE WORD JSB .XLA EQT# DEF 1651B STA EQT# JSB .XLA DRT DEF 1652B STA DRT JSB .XLA LUMAX DEF 1653B STA LUMAX JSB .XLA KEYWD DEF 1657B STA KEYWD JSB .XLA XEQT DEF 1717B STA XEQT * LDA LU,I GET THE LU TO LOCAL MEMORY STA CRTLU LDA .EOF START THE PRINT LDB DM6 JSB PRINT JSB TOD JSB STARS HEADER IS NOW DONE WE IS READY LDA FLPRM,I GET THE FLAG PRAM STA PARM2 AND SET THE PRAM XIF CPA "AL" IF ALL CODED THEN JMP FULL GO REPORT ALL * CPA "SM" ALMOST ALL?? JMP FULL YES GO DO IT * CPA "PA" IF PARTITION REPORT REQUESTED JMP WHATP YES, SHOW PARTITIONS * LDA XEQT GET CURRENT SESSION ADDRESS ADA D32 FROM THE ID JSB .XLA A,I AND DEF A,I SZA IF NOT ZERO STA SESID SAVE IT LDA SESID WELL WHAT DO WE HAVE?? SZA,RSS IF ZERO JMP FULL REPORT ALL ACTIVE PGMS. * JMP SES DO SESSION REPORT * FULL CLA SET UP TO DO FULL REPORT STA SESID SESSION ID TO ZERO * * REPORT IS TO BE SESSION RELATED ONLY * SES LDA .HEAD GET THE HEAD LDB DM74 AND JSB PRINT PRINT IT JSB STARS CLA SET UP TO START THE ID SCANN STA IDCNT STA ALL CLEAR THE ALL FLAG LDA NAMSB CLEAR THE ID STACK STA NAMST (STACK OF PROCESSED ID'S) STA DLKFL SET THE DEAD LOCK FLAG * * NXSES LDA KEYWD START THE SCAN ADA IDCNT GET KEY WORD ADDRESS JSB .XLA A,I GET THE ID ADDRESS DEF A,I STA IDPNT SET IT DOWN IN CASE THIS IS IT SZA,RSS END OF LIST?? JMP FINX YES GO CHECK ALL FLAG * ADA D14 IS A SHORT ID JSB .XLB A,I GET FLAG WORD DEF A,I BLF,BLF ROTATE IT AROUND BLF,SLB,BLF WELL?? JMP FINX YES END OF USEFUL ID'S * INA CHECK IF ID IS IN USE JSB .XLB A,I GET STATUS DEF A,I SZB ZERO DORMANT JMP NOTDM NOT DORMANT CONSIDER IT * ADA D2 GET THE TIME LIST WORD JSB .XLB A,I GOT IT DEF A,I BLF,SLB IN THE TIME LIST?? RSS YES JMP NOYET NO DON'T WORRY ABOUT THIS ONE * * * NOTDM LDA IDPNT RESTORE A TO THE ID ADDRESS LDB SESID GET THE SESSION ID SZB,RSS IF ZERO JMP MAIN GO DO THE ALL TESTS * ADA D32 INDEX TO THE SESSION WORD JSB .XLA A,I GET THE WORD DEF A,I CPA B IN THE SESSION?? JMP THISS YES GO DO IT * NOYET ISZ IDCNT NO INDEX THE COUNT JMP NXSES AND TRY AGAIN * * THISS JSB THIS CHECK IF ALREADY REPORTED JMP NOYET ALREADY DONE DON'T DO IT TWICE * THIS1 LDB IDPNT CHECK IF THE PROGRAM IN IN A FATHER SON ADB D20 CHAIN JSB .XLA B,I GET FATHER POINTER DEF B,I RAL POSITION THE BIT SSA IS THEIR A FATHER? JMP POP YES GO TRY HIM * ADB DM5 NO TRY FOR A SON JSB .XLA B,I GET STATUS WORD DEF B,I AND B10K ISOLATE THE WAITING BIT SZA SET?? JMP PROGN YES THIS IS A PROGININATOR * LDA ALL AN INDEPENDENT PROG. CHECK IF OK TO REPORT SZA WELL? JMP PROGN YES GO DO IT * JMP NOYET NO SKIP IT * POP RAR THERE IS A FATHER GO UP TO GET HIM AND B377 ISOLATE HIS NUMBER ADA M1 AND COMPUTE HIS ADA KEYWD ADDRESS JSB .XLA A,I GET HIS ID ADDRESS DEF A,I LDB IDPNT SAVE THE CURRENT ONE STB PROCS IN TEMP STA IDPNT AND SET IT UP JSB THIS HAVE WE BEEN HERE BEFORE?? RSS YES SKIP FOR FURTHER TESTS JMP THIS1 NO GO CHECK IF THE PROGIN. YET * LDB ALL CHECK IS SECOND SCAN CPB D2 IF SO THEN IT IS NOT AN ERROR RSS ELSE LET JMP THIS1 NATURE TAKE ITS COURSE * LDA PROCS NOT ERROR STA IDPNT RESTORE THE SON AND * * PROGN JSB THIS MAKE SURE WE ARE NOT IN A LOOP JMP DEAD REPORT A DEAD LOCK * JSB STKNA WE ARE GOING TO PRINT THIS ONE LDB D15 GET STATUS JSB IDWRD AND AND B07 SET IT UP STA STATS FOR THE PROCS SUB. JSB PROCS PROCESS IT LDA SON CHECK IF A SON FOUND SZA IF SO STA IDPNT SET UP TO PRINT HIM SZA WELL?? JMP PROGN YES GO DO IT * LDB ALL IF ALL IS 2 THEN CPB D2 DON'T RESET IT LDA B STA ALL CLEAR ALL IF NOT 2 LDB LNAID IF LAST NAME PRINTED WAS NOT SZB,RSS THE ONE WE WERE REPORTING JMP ENDBL (IT WAS SKIP IT) * STB IDPNT AND SET UP TO RUN DOWN THE BLOCK CPA D2 IF ALREADY IN INDEPENDENTS RSS DON'T STEP ALL ISZ ALL ELSE SET THE ALL FLAG DLD BLOCK TELL HIM WHAT WE ARE DOINT JSB PRINT JMP THIS1 * ENDBL DLD INDEP SEND TWO STARS JSB PRINT LDA NAMST UP DATE THE STA DLKFL THE DEAD LOCK FLAG JMP NOYET AND CONTINUE SCAN * * FINX CLA STA IDCNT START THE SCAN ALL OVER CPA ALL IF ALL READY DONE RSS THEN JMP FINIS QUIT * LDA D2 AND STA ALL SET UP TO PICK UP THE INDEPENDENTS JMP NXSES GO DO IT * * DEAD CMA CHECK IF A TRUE DEAD LOCK ADA DLKFL TRUE IF IN SAME DEPEND LOOP SSA,RSS WELL JMP DEAD2 NO JUST A COLISION * DLD DEMES SEND THE DEAD LOCK MESSAGE JSB PRINT DEAD2 JSB SETPT SEND A WARNING MESSAGE AND LDA .SEAB SET UP THE SEE ABOVE MESSAGE JSB MVBYT MOVE IT IN DEF .SEAB+1 LDA IDPNT GET THE NAME TO REFERENCE JSB MVNAM AND MOVE IT INTO THE MESSAGE CLA STA LNAID CLEAR THE FLAG WORD JSB OUTPT SEND THE LINE TO THE DEVICE LDB ALL IF DOING ALL CPB D2 THEN JMP ENDBL JUST CONTINUE * CLA ELSE CLEAR STA ALL THE FLAG JMP ENDBL AND CONTINUE * * STKNA NOP STACK AN ID SEGMENT ADDRESS LDA IDPNT STA NAMST,I ISZ NAMST PUSH POINTER JMP STKNA,I AND RETURN * * THIS NOP CHECK IF ID IS IN STACK (P+1 IF SO, ELSE P+2) LDA NAMSB GET STACK BASE THISO CPA NAMST END OF STACK? JMP THISX YES ALL OK * LDB A,I NO GET THE ENTRY CPB IDPNT HERE ALREADY? JMP THIS,I YES EXIT * INA NO TRY NEXT ONE JMP THISO * THISX ISZ THIS NOT FOUND EXIT JMP THIS,I * SON NOP LNAID NOP ID ADDRESS OF LAST NAME PRINTED SESID NOP B10K OCT 10000 DM5 DEC -5 ALL NOP "AL" ASC 1,AL "SM" ASC 1,SM "PA" ASC 1,PA * BLOCK DEF *+2 DEC -15 OCT 0,0 ASC 6,** BLOCK ** INDEP DEF *+2 DEC -6 OCT 0,0 ASC 1,** DEMES DEF *+2 DEC -28 OCT 0,0 ASC 12,*********** DEAD LOCK ** .SEAB DEF *+2 DEC 32 OCT 0,0 ASC 14,*** SEE ABOVE FOR REPORT ON NAMST NOP DLKFL NOP NAMSB DEF *+1 BSS 256 SPC 2 * MAIN ADA D15 VERIFY JSB .XLA A,I THAT THIS DEF A,I AND B17 IDSEG(16[4-0])=PROG STATUS CPA D3 IF IN GEN WAIT JMP MAYBE GO TEST FOR "SOME OPTION" * SZA NOT DORMANT ? JMP THISS ACTIVE SO PROCESS IT ! * LDB D17 VERIFY JSB IDWRD THAT THIS ALF,SLA IDSEG(18[12])=TIME LIST INDICATOR JMP THISS PROG IS IN TIME LIST ! * JMP NOYET ELSE GO TRY THE NEXT ONE * MAYBE LDA ALL IF DOING FATHER SON TYPES LDB PARM2 OR IF NOT "SOME OPTION CPB "SM" THEN SZA,RSS GO JMP THISS GO DO IT * JMP NOYET ELSE TRY NEXT ONE * * * D2 DEC 2 D3 DEC 3 D5 DEC 5 D6 DEC 6 D12 DEC 12 D14 DEC 14 D15 DEC 15 D16 DEC 16 D17 DEC 17 D21 DEC 21 B07 OCT 7 B77 OCT 77 B17 EQU D15 CRTLU NOP PARM2 NOP IDCNT NOP IDPNT NOP STATS NOP STACK OCT 0,0 BSS 45 .STAK DEF STACK STKPT NOP .TM. DEF STACK+31 .DNTM DEF STACK+26 .LAST DEF STACK+36 ASTER OCT 0,0 UNL REP 35 ASC 1,** LST .ASTE DEF ASTER .STAR DEF ASTER+2 DM4 DEC -4 D7 DEC 7 SPC 4 PROCS NOP JSB SETPT CLEAR THE STACK CLB AND STB SON THE SON FLAG LDB D14 JSB IDWRD GET PROG TYPE AND D7 CPA D1 RESIDENT PROGRAM? RSS JMP PRLNG NO, PROCESS DISC RESIDENT * LDA .RSDT YES, RESIDENT PROGRAM JSB MVBYT PRINT IT IS IN PARTITION 0 DEF D6 * JMP NAME GO GET PROGRAM NAME * PRLNG LDB D21 GET CONTENTS JSB IDWRD OF WORD 22 STA NUM (PARTITION #) STA B AND B77 SSB,RSS WAS PROG ASSIGNED TO PTTN SZA NO, WAS IT IN ANY PTTN? JMP PRPTN YES, ASSIGNED OR IN PTTN (NOT 1) * LDB D8 JSB IDWRD SZA HAS PROGRAM BEEN SUSPENDED BEFORE? JMP PRPT YES, THEN PARTITION #1 IS OK. * LDA .SPAC NO, PROGRAM MAY NOT HAVE BEEN LOADED JSB MVBYT DEF D2 JMP PRASG DO ASSIGNMENT INDICATOR * PRPT CLA PRPTN INA CONVERT TO ASCII JSB .ASC2 AND ADD TO STACK * PRASG LDA .SPAC LDB NUM SSB WAS PROG ASSIGNED TO PTTN? LDA .A YES, PUT 'A' IN LINE JSB MVBYT ELSE PUT A SPACE IN DEF D1 OUTPUT LINE * LDA NUM ALF,RAL GET NUMBER OF PAGES RAL IN PARTITION AND B37 INA ADD 1 FOR BASE PAGE JSB .ASC2 CONVERT TO ASCII LDA .SPAC JSB MVBYT PUT A SPACE DEF D1 * * NAME LDA IDPNT CALC 'FROM' JSB MVNAM MOVE NAME TO OUTPUT STACK CLA CLEAR THE NAME MOVED FLAG STA LNAID FOR SESSION REPORTS * JSB PSTAR PUSH AN ASTERISK SPC 2 TYPE LDB D14 GET PROGRAM TYPE JSB IDWRD AND D7 MASK OFF IDSEG(15[2-0]) STA NUM SAVE PROG TYPE FOR A WHILE JSB .ASC1 & STORE BYTE LDB D28 GET EMA WORD FROM ID SEG LDA NUM CPA D1 IS IT MEM. RES. PROG? CLA,RSS YES, SKIP EMA STUFF JSB IDWRD LDB .SPAC SZA IS IT EMA? LDB .E YES, PUT 'E' IN LINE LDA B ELSE USE SPACE JSB MVBYT DEF D1 JSB PSTAR PUSH AN ASTERISK * PRIOR LDB D6 GET PROG PRIORITY JSB IDWRD IN 'A'REG JSB ZASC5 CONVERT TO ASCII & ADD TO STACK * LDB D20 JSB IDWRD LDB .SPAC SSA IF RUNNING UNDER BATCH, LDB .B PRINT 'B' LDA B ELSE PRINT SPACE JSB MVBYT DEF D1 SPC 2 LDA STATS CALC STATUS COLUMN SZA,RSS DORMANT ? JMP M NO ASTERISKS NECESSARY MPY D5 5 CHARS PER COLUMN STA NUM SET UP MOVE LDA .STAR 'A'REG=SOURCE JSB MVBYT MOVE BYTES,R/L DEF NUM BER OF BYTES * M LDA STATS CONVERT STATUS TO ASCII JSB .ASC2 & PUSH ONTO STACK * LDA STATS GET STATUS CPA D2 I O SUSPEND ? JMP EQT YES-PROCESS EQT# CPA D3 WAIT LIST ? JMP WAIT YES-PROCESS WAIT LDA .SPAC ADD ONE MORE SPACE JSB MVBYT DEF D1 JMP TLIST CHECK TLIST SPC 2 EQTPT NOP #EQTS NOP .RSDT DEF *+1 ASC 3, 0 -- .A DEF *+1 ASC 1,AA .B DEF *+1 ASC 1,BB .E DEF *+1 ASC 1,EE D28 DEC 28 SKP EQT CLA PROG'S IN I/O SUSPEND STA #EQTS SET UP EQT INDEX * EQTLP LDA #EQTS GET EQT INDEX MPY D15 (15 WORDS EQT) ADA EQTA ADD ON EQT AREA BASE STA EQTPT SAVE THIS EQT'S ADDRESS JSB .XLA A,I GET CONTENTS OF EQT'S FIRST WORD DEF A,I * IDSLP SZA,RSS SCAN SUSPEND LIST. NULL LIST? JMP NXTEQ YES-GO TO NEXT EQT CPA IDPNT NO-POINTS TO OUR ID SEG ? JMP FNDEQ YES-GO PROCESS. SSA IF INDIRECT MUST BE GARBAGE JMP NXTEQ JSB .XLA A,I NO-NEXT LIST ELEMENT DEF A,I JMP IDSLP & CONTINUE THE SEARCH * NXTEQ ISZ #EQTS STEP EQT CNTR FOR NEXT EQT ENTRY LDA #EQTS ARE WE THRU ? CPA EQT# COMPARE WITH BASE PAGE COUNT JMP OSCAR YES-MUST BE OSCAR JMP EQTLP NO- GOTO EQT LOOP * OSCAR LDA .EXEC MOVE " ,EXEC" ONTO STACK JSB MVBYT DEF D6 JMP TLIST & CHECK TIME LIST SPC 2 .EXEC DEF *+1 ASC 3,, EXEC .CMBL EQU .EXEC COMMA, BLANK B140K ABS 140000B .LPAR DEF *+1 ASC 1,( .LBRK DEF *+1 ASC 1,[ .IOBE DEF *+1 ASC 1,]) * SPC 2 FNDEQ EQU * PUSH ", EQ(L[DEV.STAT]) *" LDA .CMBL MOVE COMMA AND BLANK JSB MVBYT DEF D2 LDA #EQTS CALC EQT # INA JSB .ASC2 CONVERT TO ASCII LDA .LPAR PUSH "(" ONTO STACK JSB MVBYT DEF D1 * LDB EQTPT GET DEV.LOG.STATUS ADB D4 JSB .XLA B,I DEF B,I ALF,ALF STA EQST SET UP FOR BINARY STATUS ALF,ALF AND B140K MASK OFF LOGICAL STATUS RAL,RAL RIGHT JUSTIFY IN WORD JSB .ASC1 CONV TO ASCII & STORE LDA .LBRK PUSH "[" ONTO STACK JSB MVBYT DEF D1 * LDA DM8 SET UP LOGICAL STATUS STA CNT COUNTER BINLP LDA EQST CONVERT STATUS WORD TO BINARY RAL ROTATE CCW STA EQST SAVE IT AND D1 MASK OFF LSB(IT) JSB .ASC1 CONV TO ASCII & STORE ISZ CNT DONE 8 ? JMP BINLP NO-LOOP * LDA .IOBE MOVE LAST PART OF MESSAGE JSB MVBYT PUSH DEF D2 JMP TLIST CHECK TLIST SPC 2 DM8 DEC -8 D20 DEC 20 REASN NOP TEST EQU REASN EQST NOP SKP WAIT LDA .EXEC PUSH "," ONTO STACK JSB MVBYT FOR EXPLANATION DEF D1 * CLB,INB GET IDSEG(2) JSB IDWRD STA REASN CPA .RNTB RESOURCES LOCK ? JMP RESLK YES-PUSH "RESOURCE" ONTO STACK * CPA .CLAS NO-CLASS LOCK ? JMP CLSLK YES-PUSH "CLASS #" ONTO STACK * CPA D4 NO-DEVICE DOWN ? JMP DEVDN YES-PUSH "DEVICE DOWN" ONTO STACK * JSB TSTWD RNTBL<=IDSEG(2)<=[RNTBL] ? .RNTB DEF $RNTB+0 JMP RNLCK YES-PUSH "RN LOCK" ONTO STACK * JSB TSTWD CLASS<=IDSEG(2)<=[CLASS] ? .CLAS DEF $CLAS+0 JMP CLGET YES-PUSH "CLASS GET" ONTO STACK * LDA 1650B EQT <= IDSEG(2) <= #EQTS CMA,INA - S.A. OF EQT ADA REASN + POINTER SSA IF -, THEN POINTER < EQT S.A. JMP SONID FORGET IT CLB RESULT IS ADD REL S.A.EQT DIV D15 MOD 15 INA + 1 STA TEMP = EQT # CMA,INA -EQT# ADA 1651B + # EQT'S SSA,RSS IF POS,THEN VALID EQT # JMP BL SO PROCESS IT * SONID LDA REASN GET SON'S IDSEG ADDRESS STA SON POSSIBLE SON FOUND JSB MVNAM MOVE SON'S NAME ONTO STACK LDB D15 JSB IDWRD ALF,SLA JMP TLIST BIT 12 SET, HAVE SON * CLA NOT A SON STA SON CLEAR THE FLAG LDA .QUE BIT 12 CLEAR, SON YET TO BE JMP PUSH8 SPC 2 .BLIM DEF *+1 ASC 3,BL,EQT00 * BL LDA .BLIM SET UP BUFFER LIMIT MESSAGE JSB MVBYT DEF D6 LDA TEMP JSB .ASC2 CONVERT EQT# & PUSH JMP TLIST TEMP NOP SPC 2 .QUE DEF *+1 ASC 4,'S QUEUE .RN?? DEF *+1 ASC 4,RESOURCE RESLK LDA .RN?? PUSH "RN ??" ONTO STACK JMP PUSH8 SPC 2 .CL?? DEF *+1 ASC 4,CLASS # CLSLK LDA .CL?? PUSH "CL ??" ONTO STACK PUSH8 JSB MVBYT PUSH 8 CHARS ONTO STACK DEF D8 JMP TLIST SPC 2 .EQDN DEF *+1 ASC 5,LU/EQ DN DEVDN LDA .EQDN PUSH "LU,EQ DN" ONTO STACK JSB MVBYT DEF D8 LDB D2 JSB IDWRD GET LU# FROM SUSPENDED ID STA REASN SAVE IT TEMPORARILY SSA IF NEGATIVE, IT IS EQT ADDR JMP DVDNE OF DOWN DEVICE * JSB .ASC4 PUT LU LEADING BLANKS * CCA FIND EQT NO. FOR LU ADA REASN AND B77 ADA DRT JSB .XLA A,I DEF A,I AND B77 ADA M1 STA #EQTS * MPY D15 ADA EQTA STA EQTPT JMP FNDEQ GO PRINT EQT STUFF. * DVDNE CMA,INA SAVE EQT ADDR OF DOWN DEVICE STA EQTPT LDA REASN CONVERT EQT ADDR TO EQT # ADA EQTA BY SUBTRACTING EQT BASE ADDR CMA,INA CLB DIV D15 AND DIVIDE BY 15 INA BUMP BY 1 FOR FIRST EQT STA #EQTS LDA .SPAC PUT 4 BLANKS FOR LU# JSB MVBYT DEF D4 JMP FNDEQ PUT OUT EQT INFO SPC 2 B37 OCT 37 @DRT EQU 1652B @LUMX EQU 1653B .RNLK DEF *+1 ASC 2,RN 00,LKPRG=PROGA . .LKPR DEF *+1 ASC 4,,LKPRG= * RNLCK STA RN SAVE RN# TEMP LDA @DRT GET DRT ADDRESS STA PTR SET UP POINTER LDA @LUMX GET MAX # OF LU'S CMA,INA SET UP COUNTER STA CNT LLOOP EQU * SEARCH FOR LU LOCK JSB .XLA PTR,I DEF PTR,I GET DRT ENTRY RRR 6 POSITION LU LOCK RN AND B37 & MASK IT CPA RN LU LOCK ? JMP LULCK YES-PROCESS IT ISZ PTR NO LOOP ISZ CNT JMP LLOOP LDA .RNLK PUSH "RN LK" ONTO STACK JSB MVBYT DEF D4 LDA RN PROCESS RNLCK JSB ZASC3 JSB PLOCK PUT PROG NAME INTO MESSAGE JMP TLIST SPC 2 .LULK DEF *+1 ASC 3,LULK 00,LKPRG=PROGA . * LULCK LDA .LULK PUT "LULK" ONTO STACK JSB MVBYT DEF D4 LDA CNT PROCESS LU LOCK - FIND ADA @LUMX OWNER'S NAME INA JSB .ASC3 PUT LU# IN MESSAGE JSB PLOCK PUT PROG NAME IN MESSAGE JMP TLIST SPC 2 PLOCK NOP LDA .LKPR PUSH ",LKPRG=" ONTO STACK JSB MVBYT DEF D7 LDA .RNTB ADA RN JSB .XLA A,I DEF A,I AND B377 GET RESOURCE LOCKER'S ID SEG # CPA B377 IS IT GLOBAL? JMP PLCK9 YES. ADA M1 ADA KEYWD JSB .XLA A,I DEF A,I JSB MVNAM MOVE NAME JMP PLOCK,I * PLCK9 LDA .GLBL JSB MVBYT MOVE NAME 'GLOBL' DEF D5 JMP PLOCK,I * .GLBL DEF *+1 ASC 3,GLOBL M1 DEC -1 RN NOP PTR NOP CNT NOP .CLGT DEF *+1 ASC 3,CL .SPAC DEF .CLGT+2 CL# NOP * CLGET STA CL# LDA .CLGT PUSH "CL " ONTO STACK JSB MVBYT DEF D4 LDA CL# JSB ZASC3 JMP TLIST * * TLIST LDB D17 IDSEG(18[12])=TIME LIST INDICATOR JSB IDWRD ALF,SLA SET ? JMP NXTTM YES-CONV NEXT TIME JMP DUMP NO-PRINT WHAT WE'VE GOT. SPC 2 D8 DEC 8 SPC 2 NXTTM LDA .TM. CALC # OF STARS TO FILL LINE CLE,ELA CMA,INA ADA STKPT CMA,INA SSA,RSS MORE THAN WE CAN FIT? JMP NXTM2 NO, OK * JSB OUTPT YES, LU/DN MSG TOO LONG LDA .DNTM COPY LINE AFTER PRINTING IT CLE,ELA AND ADD TIME STUFF TO IT STA STKPT JMP NXTTM * NXTM2 STA NUM & SAVE IT LDA .STAR SET UP FOR MOVE JSB MVBYT DEF NUM * LDA IDPNT ADA D18 JSB CNVTM * DUMP JSB OUTPT DISPLAY STACK JMP PROCS,I RETURN SPC 2 FINIS JSB STARS EOL + 70 ASTERISKS * DNDEV JSB SETPT RESET STACK FOR DOWN LU'S. LDA .DNLU PRINT LINE HEAD. JSB MVBYT DEF D9 LDA STKPT SAVE CURRENT POSITION STA PTR IN CASE NEED MORE LINES * LDA DRT GET LU TABLE AREA ADDRESS, ADA LUMAX POSITION TO WORD TWO STA EQTPT TABLE AND SAVE. CLA INITIALIZE STA #EQTS COUNTER. * DNLU1 JSB .XLA EQTPT,I DEF EQTPT,I GET LU'S STATUS. ISZ #EQTS SSA,RSS IS IT DOWN? JMP NXTLU NO--GET NEXT LU. * LDA .LAST CLE,ELA CMA,INA NEGATE LAST POSITION TO START ADA STKPT SEE IF TOO FULL YET. SSA LINE FULL YET? JMP DNLU2 NO, DO IT * JSB OUTPT YES, DUMP LINE LDA PTR SET UP NEW LINE STA STKPT JUST LIKE THE PREVIOUS DNLU2 LDA .CMBL YES--PROCESS IT. JSB MVBYT PUSH A ','. DEF D1 LDA #EQTS CONVERT LU# JSB .ASC3 TO ASCII. NXTLU ISZ EQTPT INCREMENT DRT WORD 2 POINTER. LDA #EQTS IF LAST, CPA LUMAX THEN GO RSS DUMP LINE. JMP DNLU1 ELSE CONTINUE. * JSB OUTPT PRINT STACK. JSB STARS E0L + LINE OF ASERISKS. * JSB SETPT RESET STACK FOR DOWN EQTS LDA .DNEQ PRINT LINE HEAD JSB MVBYT DEF D10 LDA STKPT SAVE CURRENT POSITION STA PTR IN CASE WE NEED ANOTHER LINE * LDA EQTA GET EQT TABLE AREA ADDRESS ADA D4 INDEX TO STATUS STA EQTPT PUSH POINTER CLA INIT STA #EQTS EQT COUNTER DEVLP JSB .XLA EQTPT,I DEF EQTPT,I FIND EQT'S. GET STATUS ISZ #EQTS RAL,RAL POSITION AND D3 & MASK CPA D1 IS IT DOWN RSS YES-PROCESS JMP NXTDV NO-NEXT EQT * LDA .LAST CLE,ELA CMA,INA NEGATE LAST POSITION ADA STKPT TO SEE IF FULL YET? SSA FULL YET? JMP DNEQ2 NO, DO IT * JSB OUTPT DUMP LINE LDA PTR SET UP FOR ANOTHER LINE STA STKPT JUST LIKE THE PREVIOUS DNEQ2 LDA .CMBL PUSH "," JSB MVBYT DEF D1 LDA #EQTS CONV EQT# TO ASCII JSB .ASC3 NXTDV LDA EQTPT BUMP ADA D15 TO NEXT STA EQTPT EQT STATUS WORD LDA #EQTS WAS THIS THE LAST CPA EQT# RSS YES-DUMP IT JMP DEVLP NO-CONTINUE SPC 2 DONE JSB OUTPT PRINT STACK DONE1 JSB STARS EOL + LINE OF ASTERISKS EXIT JSB TOD FINALLY TIME OF DAY LDA .EOF ANOTHER BLANK LINE LDB DM6 JSB PRINT SPC 2 IFZ JMP WHZIT,I RETURN FOR DUMP ALAL. VERSION XIF IFN LDA XEQT CHECK IF I AM IN TIME LIST ADA D17 XLA A,I GET THE WORD (*****NOTE*****) ALF,SLA WELL?? LDA PARM2 YES USE CURRENT PRAM2 STA PARM2 NO RESET PARM2 JSB EXEC I AM SERIALLY REUSABLE DEF RSTRT DEF D6 DEF ZERO DEF M1 DEF ZERO DEF PARM2 DEF CRTLU DEF SESID RSTRT JMP WHAT RESTART XIF SPC 2 ZERO OCT 0 D18 DEC 18 DM6 DEC -6 RNTBL NOP CLASS NOP NUM NOP D4 DEC 4 .DNEQ DEF *+1 ASC 5,DOWN EQT'S .DNLU DEF *+1 ASC 5,DOWN LU'S D9 DEC 9 * .EOF DEF *+1 OCT 0,0,20040 .HEAD DEF *+1 OCT 0,0 ASC 10,PT SZ PRGRM,T ,PRIOR ASC 10,*DRMT*SCHD*I/O *WAIT ASC 10,*MEMY*DISC*OPER * NE ASC 5,XT TIME *** SKP SPC 2 FROM BSS 2 TO EQU FROM+1 B377 OCT 377 SPC 2 STBYT NOP LDB TO OCT 105764 JSB SBT STB TO JMP STBYT,I SPC 2 * ('A'REG = WORD ADDRESS OF FROM) * JSB MVBYT * DEF COUNT * MVBYT NOP CLE,ELA LDB STKPT DST FROM LDA MVBYT,I ISZ MVBYT STA .MVBY DLD FROM OCT 105765 JSB MBT .MVBY NOP NOP STB STKPT JMP MVBYT,I SPC 2 PSTAR NOP LDA .STAR JSB MVBYT DEF D1 JMP PSTAR,I SPC 2 SETPT NOP LDA .STAK ADA D2 CLE,ELA STA STKPT JMP SETPT,I SPC 2 OUTPT NOP LDA .STAK LDB .STAK CLE,ELB CONV TO BYTES CMB,INB ADB STKPT ADD ON CURRENT BYTE POSITION CMB,INB JSB PRINT JMP OUTPT,I SPC 2 STARS NOP LDA .ASTE LDB DM74 JSB PRINT JMP STARS,I * DM74 DEC -74 SPC 2 * 'A'REG = UPPER LIMIT * 'B'REG = LOWER LIMIT * TEST = ??????????? * JSB TESTR * RETURN -'A'REG : POS => FALSE NEG => TRUE . TESTR NOP CMB,CLE,INB ADB TEST LDB TEST CMB,SEZ,CLE,INB ADB A ERA SIGN = E. E=0 FALSE E=1 TRUE JMP TESTR,I SPC 2 TSTWD NOP LDB TSTWD,I GET ADDR OF TABLE ISZ TSTWD JSB .XLA B,I GET UPPER LIMIT BY ADDING DEF B,I ADA B SIZE OF TABLE TO ADDR STB SAVEB SAVE ADDR OF TABLE AS LOWER LIMIT JSB TESTR SSA,RSS ISZ TSTWD LDA SAVEB CMA,INA ADA TEST JMP TSTWD,I SPC 2 * (A) = ID SEG ADDR * JSB MVNAM * MVNAM NOP MOVE NAME FROM ID SEG TO OUTPUT LINE STA LNAID SAVE LAST ID NAME USED ADA D12 LDB D3 CBX MOVE 3 WORDS FROM SYSTEM MAP LDB DWRD1 BECAUSE MBF REQUIRES JSB .MWF DEST. TO BE AT EVEN WORD LDA DWRD1 JSB MVBYT DEF D5 JMP MVNAM,I * WORD1 NOP WORD2 NOP WORD3 NOP SPC 2 PRINT NOP STA .BUFF STB CNT JSB EXEC DEF *+1+4 DEF D2 DEF CRTLU .BUFF DEF STACK DEF CNT JMP PRINT,I * TOD NOP JSB SETPT LDA @TIME JSB CNVTM JSB OUTPT JMP TOD,I SPC 2 @TIME DEF $TIME+0 MS NOP SEC NOP MIN NOP HOURS NOP DAY NOP .HOUR DEF HOURS .COLN DEF *+1 ASC 1,:: .ZERO DEF *+1 ASC 1,00 SPC 2 CNVTM NOP LDB D3 MOVE 3 WORDS OF TIME CBX TO USER MAP FROM SYS MAP LDB DWRD1 JSB .MWF JSB TMVAL CONVERT INTO COMPONENTS DEF *+1+2 DWRD1 DEF WORD1 DEF MS LDA .HOUR STA PTR LDA DM4 STA CNT JMP TLOOR * TLOOP LDA .COLN PUSH A ":" OUT JSB MVBYT DEF D1 TLOOR LDA PTR,I JSB .ASC2 CONVERT TIME TO ASCII CCA ADA PTR STA PTR ISZ CNT JMP TLOOP * LDA .ZERO ADD "0" FOR LAST NUMBER JSB MVBYT TO MULTIPLY BY 10 FOR MS DEF D1 JMP CNVTM,I RETURN WITH ASCII VALUES IN ARRAY TIME SPC 2 IDWRD NOP ADB IDPNT JSB .XLA B,I DEF B,I JMP IDWRD,I SPC 2 * 'A'REG = BINARY VALUE * 'B'REG = 5 MINUS NUMBER OF DIGITS TO BE CONVERTED * 'E'REG = 0 FOR NO ZEROES, 1 FOR LEADING ZEROES * JSB ASCII * 'A'REG = LAST BYTE * 'B'REG = BYTE ADDRESS UPDATED * ASCII NOP STA VAL CLA ELA STA FILL LDA STKPT STA TO LDA B (A)=(B)=DIGIT COUNT CODE ADB DM4 STB CCNTR SZB,RSS IF ONLY ONE DIGIT JMP LSTDG GO TO LAST DIGIT CODE ADA .N10K ADJUST POWERS OF TEN TO STA QPNTR NUMBER OF DIGITS DESIRED LOOP LDA VAL CLB DIV QPNTR,I DIVIDE BY POWER OF TEN STB VAL SAVE REMAINDER (LOWER DIGITS) SZA JMP ASCNV CPA FILL LEADING ZEROES WANTED? JMP LZERO NO, BLANK OUT IF E#0 ORIGINALLY ASCNV IOR B60 NOT 0 OR LEADING 0 WANTED STA FILL SO INSURE NO 0 GETS LOST ASCST JSB STBYT ISZ QPNTR INCRE TO NEXT POWER OF TEN ISZ CCNTR BUMP DIGIT COUNTER JMP LOOP MORE THAN 1 DIGIT LEFT LSTDG LDA VAL IOR B60 DO LAST DIGIT EVEN IF ZERO JSB STBYT STB STKPT (B) IS STILL NEXT BYTE ADDR JMP ASCII,I * LZERO LDA B40 REPLACE LEADING ZEROES JMP ASCST WITH BLANKS SPC 2 .ASC1 NOP CONVERT 1 DIGIT TO ASCII CLE LDB D4 JSB ASCII JMP .ASC1,I SPC 2 .ASC2 NOP CONVERT BINARY TO ASCII CLE LDB D3 JSB ASCII JMP .ASC2,I SPC 2 .ASC3 NOP CONVERT 3 DIGITS, LEADING BLANKS CLE LDB D2 JSB ASCII JMP .ASC3,I SPC 2 ZASC3 NOP CONVERT 3 DIGITS, LEADING ZEROES CCE LDB D2 JSB ASCII JMP ZASC3,I SPC 2 .ASC4 NOP CONVERT 4 DIGITS, LEADING BLANKS CLB,CLE,INB JSB ASCII JMP .ASC4,I SPC 2 .ASC5 NOP CONVERT 5 DIGITS, LEADING BLANKS CLB,CLE JSB ASCII JMP .ASC5,I SPC 2 ZASC5 NOP CONVERT 5 DIGITS, LEADING ZEROES CLB,CCE JSB ASCII JMP ZASC5,I SPC 2 VAL NOP .N10K DEF N10K N10K DEC 10000,1000,100,10 D1 DEC 1 D10 EQU N10K+3 QPNTR NOP CCNTR NOP FILL NOP SAVEB EQU VAL B40 OCT 40 D32 EQU B40 B60 OCT 60 SKP WHATP LDA .PHED LDB DM38 JSB PRINT PRINT HEADING FOR PARTITION STUFF JSB STARS '**********' * CLA,INA STA PTN# INIT PARTITION NUMBER CLA SET STA UFLAG NO. UNDEFINED TO ZERO JSB .XLA $MATA @MATA DEF $MATA STA PTNAD INIT PARTITION ADDR JSB .XLA $MNP GET # OF PARTITIONS @MNP DEF $MNP SZA,RSS JMP DONE IN CASE BOO-BOO MPY D7 ADA PTNAD CALCULATE ADDR OF STA LPTAD LAST PARTITION * NXPTN JSB .XLA PTNAD,I GET LINK WORD DEF PTNAD,I SSA,RSS PARTITION DEFINED? JMP CKPTN YES, CHECK STUFF * IFZ * LDB D3 UNDEFINED BUT WAS JSB PTNWD THIS DUE TO A SZA,RSS PARITY ERROR ? JMP UNDEF NO * LDA .PERR GET THE PARITY ERROR JSB MVBYT MESSAGE & DEF D16 JMP DMPTN DUMP IT * XIF UNDEF ISZ UFLAG STEP UNDEFINED FLAG JMP DMP0 GO STEP THE PT. NO. * * CKPTN JSB FLUSU FLUSE UNDEFINED IF ANY JSB SETPT SET UP THE NEW LINE LDA PTN# JSB .ASC2 PUT PART. NO. ON LINE LDB D3 JSB PTNWD GET WORD 4 SSA,RSS IS IT MOTHER PTTN? JMP NTMOM NO * LDA .M FILL IN 'M' JMP DOMCS * NTMOM LDB D4 JSB PTNWD GET WORD 5 RAL SSA,RSS IS SUBPTTN IN CHAIN MODE? JMP NTCHN NO * LDA .C FILL IN 'C' JMP DOMCS * NTCHN LDB D6 JSB PTNWD GET WORD 7 STA B LDA .SPAC USE SPACE IF NOT SUBPTTN SZB LDA .S ELSE FILL IN 'S' DOMCS JSB MVBYT DO 'M' 'C' OR 'S' DEF D1 * CKRES LDB D4 JSB PTNWD CALC ADDR OF RES-SIZE CLE,ELA RAR KEEP ONLY 10 BITS AND B1777 (STATUS JUNK IN HIGH BITS) STA PTSIZ SAVE SIZE OF PART. LDA .SPAC OUTPUT SPACE IF NOT RESERVED SEZ ELSE LDA .R USE 'R ' IF RESERVED JSB MVBYT DEF D1 * LDA PTSIZ GET PART. SIZE (MAX=1024) INA ADD 1 FOR BASE PAGE JSB .ASC5 CONVERT TO ASCII + OUTPUT * LDA .SPAC JSB MVBYT 2 MORE SPACES DEF D2 * LDB D3 JSB PTNWD ADDR OF START PAGE # AND B1777 PAGE # IN LOW 10 BITS ONLY STA PAGE# JSB .ASC4 CONVERT + OUTPUT 4 DIGITS * LDA .DASH JSB MVBYT PUT "-" ON OUTPUT STACK DEF D1 * LDA PAGE# ADA PTSIZ CALCULATE LAST PAGE # JSB .ASC4 CONVERT + OUTPUT 4 DIGITS * LDB D5 JSB PTNWD CLE,ELA PUT RT-BG BIT INTO (E) LDA .BG 'BG " IF BACKGROUND SEZ ELSE LDA .RT ' RT' IF REAL-TIME JSB MVBYT CLASS PARTITION DEF D7 * LDB D2 JSB PTNWD SZA,RSS EMPTY? JMP NOPRG YES, PRINT '' JSB MVNAM MOVE NAME TO OUTPUT * DMPTN JSB OUTPT DUMP OUTPUT STACK DMP0 ISZ PTN# INCRE PARTITION # LDA PTNAD ADA D7 INCRE TO NEXT PARTITION ADDR STA PTNAD CPA LPTAD DONE YET? RSS YES. PRINT TIME, EXIT JMP NXPTN NO. DO NEXT PARTITION * JSB FLUSU FLUSH FINAL UNDEFS IF ANY JMP DONE1 AND GO EXIT * NOPRG LDA .NONE JSB MVBYT DEF D6 JMP DMPTN SPC 2 PTNWD NOP ADB PTNAD JSB .XLA B,I DEF B,I JMP PTNWD,I * * FLUSU NOP ROUTINE TO PUT OUT LINE FOR UNDEFINED PART. LDA UFLAG ARE THERE ANY? SZA,RSS WELL? JMP FLUSU,I NO JUST RETURN * JSB SETPT YES START A LINE LDA UFLAG CACULATE THE FIRST PT. NO. CMA,INA FROM COUNT AND CURRENT #. ADA PTN# THERE JSB .ASC2 SEND IT OUT LDA UFLAG CHECK IF MORE THAN 1 CPA D1 WELL JMP ONLY1 NO JUST ONE * LDA .MINU ELSE SEND RANGE '-' JSB MVBYT TO THE LINE DEF D1 CCA NOW GET THE LAST NUMBER ADA PTN# AND SEND IT JSB .ASC2 TO THE LINE ONLY1 LDA .UNDF SEND THE UNDEF LINE JSB MVBYT DEF D14 CLA STA UFLAG JSB OUTPT SEND THE LINE JMP FLUSU,I ALL DONE EXIT SPC 2 .PHED DEF *+1 OCT 0,0 ASC 17,PTN# SIZE PAGES BG/RT PRGRM * .MINU DEF *+1 ASC 1,-- UFLAG NOP .UNDF DEF *+1 ASC 7, .PERR DEF *+1 ASC 8, * .R DEF *+1 ASC 1,RR * .S DEF *+1 ASC 1,SS * .C DEF *+1 ASC 1,CC * .M DEF *+1 ASC 1,MM * .DASH DEF *+1 ASC 1,- * .BG DEF *+1 ASC 4, BG * .NONE DEF *+1 ASC 3, .RT DEF *+1 ASC 4, RT * B1777 OCT 1777 DM38 DEC -38 PTSIZ EQU STATS PTNAD EQU EQTPT PTN# EQU IDCNT LPTAD EQU IDPNT PAGE# EQU #EQTS UNS END FTN4,L,Q SUBROUTINE VESUB(IPRS2,SDCB1) IMPLICIT INTEGER (A-Z) C COMMON /GORT/ FND2(257) C DIMENSION FND(256) DIMENSION MES2(22), MES3(19) C DATA MES2/2H22,2HBA,2HD ,2HTI,2HME,2H L,2HIS,2HT ,2HPO,2HIN, & 2HTE,2HR ,2HFO,2HR ,2HID,2H S,2HEG,2H A,2HT ,2H.., & 2H..,2H../ DATA MES3/2H19,2HID,2H S,2HEG,2HME,2HNT,2H A,2HT ,2H..,2H.., & 2H..,2H N,2HOT,2H I,2HN ,2HAN,2HY ,2HLI,2HST/ C C VESUB VERIFIES THE LINK LISTS OF THE ID SEGMENTS. IT C CHECKS THAT ALL OCCUPIED SEGMENTS ARE IN THE APPROPRIATE C SCHEDULER LIST BY CROSS-CHECKING THEIR STATUS. THE C POINTERS OF THE TIME LIST ARE ALSO VALIDTED. C C IF $ZZZZ IS NON-ZERO, THIS FACT IS NOTED. C C------------------------------------------------------------------ C C SCAN THE KEYWORD TABLE TO FIND THE LAST LONG ID SEGMENT C KEYTB = SGET(1657B) KBEG = SGET(KEYTB) DO 20 K = KEYTB,KEYTB+256 J = K - KEYTB + 1 FND2(J) = SGET(K) IF(FND2(J).EQ.0) GO TO 30 IF(IAND(SGET(SGET(K)+14),20B).NE.0) GO TO 30 20 CONTINUE CALL PRNT(34H17CAN'T FIND END OF KEYWORD TABLE ) 30 K = K - 1 FND2(J) = 0 KEND = SGET(K) C C ZERO OUT FLAG ARRAY; LOCATE $ZZZZ C DO 40 J = 1,256 FND(J) = 0 40 CONTINUE CALL FNDET(6H$ZZZZ ,IERR,SDCB1,MYTYP,ZZZZ) C C TRACE THE FIVE SCHEDULER LISTS AND $ZZZZ C IF (TLIST(FND,ZZZZ, KBEG,KEND,0).NE.0) RETURN IF (TLIST(FND,1711B,KBEG,KEND,1).NE.0) RETURN IF (TLIST(FND,1713B,KBEG,KEND,3).NE.0) RETURN IF (TLIST(FND,1714B,KBEG,KEND,4).NE.0) RETURN IF (TLIST(FND,1715B,KBEG,KEND,5).NE.0) RETURN IF (TLIST(FND,1716B,KBEG,KEND,6).NE.0) RETURN C C NOW CHECK FOR DORMANT, I/O WAIT, AND TIME LIST C DO 70 L = KEYTB,K J = IGET(L) IF(IFBRK(0).NE.0) RETURN IST = IAND(IGET(J+15),17B) C C TEST FOR STATUS NOT 0 OR 2 AND NOT IN LIST C 50 IF(IST.EQ.0 .OR. IST.EQ.2 .OR. FND(IFND(J)).NE.0) & GO TO 60 CALL OCT(J,MES3(9)) CALL PRNT(MES3) C C TEST FOR INVALID TIME LIST POINTERS C 60 TON = IAND(IGET(J+17),10000B) TLNK = IGET(J+16) IF(TON.EQ.0 .OR. TLNK.EQ.0 .OR. & (TLNK.GE.KBEG .AND. TLNK.LE.KEND)) GO TO 70 CALL OCT(J,MES2(20)) CALL PRNT(MES2) 70 CONTINUE IF(IGET(ZZZZ).EQ.0) RETURN CALL PRNT(40H20$ZZZZ IS NON-ZERO - CRASH WAS IN $LIST) RETURN END INTEGER FUNCTION TLIST(FND,ADR,KBEG,KEND,ST) IMPLICIT INTEGER (A-Z) DIMENSION FND(256) DIMENSION MES1(22),MES2(25),MES3(14) C DATA MES1/2H22,2HST,2HAT,2HUS,2H D,2HOE,2HSN,2H'T,2H A,2HGR, & 2HEE,2H F,2HOR,2H I,2HD ,2HSE,2HG ,2HAT,2H ,2H.., & 2H..,2H../ DATA MES2/2H25,2HID,2H S,2HEG,2H A,2HPP,2HEA,2HRS,2H I,2HN , & 2HLI,2HST,2HS ,2HMO,2HRE,2H T,2HHA,2HN ,2HON,2HCE, & 2H A,2HT ,2H..,2H..,2H../ DATA MES3/2H14,2HIN,2HVA,2HLI,2HD ,2HPO,2HIN,2HTE,2HR , & 2HAT,2H ,2H..,2H..,2H../ C C TLIST TRACES THE SCHEDULER LIST SPECIFIED BY ADR AND SETS WORDS C IN FND TO ONE TO INDICATE THAT ID SEGMENTS ARE IN SOME SCHEDULER C LIST. THE RETURN VALUE IS 0 OR -1, DEPENDING ON WHETHER OR NOT C A BREAK WAS DETECTED DURING EXECUTION C C--------------------------------------------------------------------- TLIST = 0 ADDR = ADR C C CHECK FOR ITEMS IN MORE THAN ONE LIST C 5 IF(IFBRK(0).NE.0)RETURN ADDR2 = ADDR ADDR = IGET(ADDR) IF(ADDR.EQ.0) RETURN T = IFND(ADDR) IF(T.EQ.0) GO TO 8 IF(FND(T).EQ.0) GO TO 7 CALL OCT(ADDR,MES2(23)) CALL PRNT(MES2) RETURN 7 FND(T) = 1 C C CHECK FOR CORRECT STATUS C IF(IAND(IGET(ADDR+15),17B).EQ.ST.OR.ST.EQ.0)GOTO 8 CALL OCT(ADDR,MES1(20)) CALL PRNT(MES1) C C CHECK FOR POINTER IN RANGE C 8 IF(IFND(ADDR).NE.0)GO TO 5 CALL OCT(ADDR2,MES3(12)) CALL PRNT(MES3) RETURN 20 GO TO 5 END INTEGER FUNCTION IFND(IADDR) IMPLICIT INTEGER (A-Z) COMMON /GORT/ FND2(257) C DO 10 IFND = 1,257 IF(FND2(IFND).EQ.0) GO TO 20 IF(FND2(IFND).EQ.IADDR) RETURN 10 CONTINUE 20 IFND = 0 RETURN END BLOCK DATA GORT,BLOCK DATA FOR VESUB IMPLICIT INTEGER (A-Z) COMMON /GORT/ FND2(257) C END END$