ASMB,R,Q,C
* 
*  **************************************************************** 
*  * (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 WHZAT FOR RTE-IV
      NAM WHZAT,1,1 92067-16007 REV.1926 790506 
* 
*     NAME:    WHZAT
*     SOURCE:  92067-18007
*     RELOC:   92067-16007
*     PRGMR:   E.J.W. 
* 
      SUP PRESS ALL EXTRANEOUS LISTING
      EXT EXEC,$TIME,$RNTB,$CLAS,TMVAL
      EXT $MATA,$MNP
* 
A     EQU 0 
B     EQU 1 
* 
EQTA  EQU 1650B 
EQT#  EQU 1651B 
DRT   EQU 1652B 
LUMAX EQU 1653B 
KEYWD EQU 1657B 
* 
* 
*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    <NONE>
*  6C    16     96- 111 BG    <NONE>
*  7C    16    112- 127 BG    <NONE>
*  8M    64    128- 191    RT <NONE>
*  9SR   16    128- 143    RT <NONE>
* 10S    16    144- 159    RT PROGQ 
* 11S    16    160- 175    RT SAMPL 
* 12SR   16    176- 191    RT <NONE>
* 13 R   64    192- 255 BG    EMAID 
* 14  <UNDEFINED> 
* 15  <UNDEFINED> 
* **********************************************************************
* 09:00:21:310
* 
* 
      SKP 
WHAT  XLA B,I 
      CLE,SZA,RSS   SCHED W PRAM ?
      CLA,CCE,INA   NO-DEFAULT TO LU 1
      STA CRTLU     SAVE LU FOR OUTPUT
      INB 
      XLA B,I 
      STA PARM2     SAVE SECOND PARAMETER 
      INB 
      XLA B,I       GET SPECIAL LU PARAM
      SZA,RSS        IN CASE OF PREV RUN
      LDA CRTLU 
      SEZ           DEFAULT NEEDED? 
      STA CRTLU      YES
      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 
      SZA           WAS SECOND PARAMETER GIVEN? 
      JMP WHATP      YES, SHOW PARTITIONS 
* 
      SPC 2 
      LDA .HEAD     ERASE EOL + COLUMN HEADER 
      LDB DM74
      JSB PRINT 
      JSB STARS     ERASE EOL + A LINE OF ASTERISKS 
      CLA           ZERO IDSEG #
      STA IDCNT     AND AWAY WE GO !
      SPC 2 
      SKP 
MAIN  JSB SETPT     BEGIN MAIN CODE.  INIT STACK
      LDA KEYWD     GET ADDRESS OF KEYWORD BLOCK
      ADA IDCNT     ADD ON IDSEG # TO INDEX 
      XLA A,I        TO THIS LOOP'S WORK
      STA IDPNT     IDSEG(1)
* 
      SZA,RSS       IF ZERO,
      JMP FINIS     THEN WE'RE THRU WITH ID SEG'S 
* 
      LDB D15       ELSE VERIFY 
      JSB IDWRD      THAT THIS
      AND B17         IDSEG(16[4-0])=PROG STATUS
      STA STATS        PROGRAM IS 
      SZA                NOT DORMANT ?
      JMP PROCS     ACTIVE SO PROCESS IT !
* 
      LDB D17       VERIFY
      JSB IDWRD     THAT THIS 
      ALF,SLA         IDSEG(18[12])=TIME LIST INDICATOR 
      JMP PROCS        PROG IS IN TIME LIST ! 
      JMP BUMP0     ELSE NEXT INDEX(IDSEG #)
* 
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
B77   OCT 77
B17   EQU D15 
CRTLU NOP 
PARM2 NOP 
IDCNT NOP 
IDPNT NOP 
STATS NOP 
STACK OCT 0,0 
      BSS 35
.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 EQU * 
      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 
* 
      JSB PSTAR     PUSH AN ASTERISK
      SPC 2 
TYPE  LDB D14       GET PROGRAM TYPE
      JSB IDWRD 
      ALF,ALF       CHECK FOR SHORT ID
      ALF,SLA,ALF    SHORT ?
      JMP FINIS       YES,STOP ID CHECK 
      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 
      XLA A,I       GET CONTENTS OF EQT'S FIRST WORD
* 
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 
      XLA A,I       NO-NEXT LIST ELEMENT
      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
      LDA 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 
      JSB MVNAM      MOVE SON'S NAME ONTO STACK 
      LDB D15 
      JSB IDWRD 
      ALF,SLA 
      JMP TLIST     BIT 12 SET, HAVE SON
* 
      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 
      LDA 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   *1926DLS*DEL NEXT LINE
      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
      LDA 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
      XLA A,I 
      AND B377      GET RESOURCE LOCKER'S ID SEG #
      CPA B377      IS IT GLOBAL? 
      JMP PLCK9      YES. 
      ADA M1
      ADA KEYWD 
      XLA 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 
BUMP0 ISZ IDCNT 
      JMP MAIN
      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 LDA 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 LDA 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 
      JSB EXEC      I AM SERIALLY REUSABLE
       DEF RSTRT
       DEF D6 
       DEF ZERO 
       DEF M1 
       DEF ZERO 
       DEF PARM2
       DEF CRTLU
RSTRT JMP WHAT      RESTART 
      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 
      XLA B,I       GET UPPER LIMIT BY ADDING 
      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
      ADA D12 
      LDB D3
      CBX           MOVE 3 WORDS FROM SYSTEM MAP
      LDB DWRD1      BECAUSE MBF REQUIRES 
      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 
      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 
      XLA 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