ASMB,C,Q,N
      IFN           * START RTE CODE
      HED DLIST  91750-16072 REV 2013 * (C) HEWLETT-PACKARD CO. 1980
      XIF           * END RTE CODE
* 
      IFZ           * START RTE-M/L CODE
      HED DLIST  91750-16073 REV 2013 * (C) HEWLETT-PACKARD CO. 1980
      XIF           * END RTE-M/L CODE
* 
      IFN           * START RTE CODE
      NAM DLIST,19,30 91750-16072 REV 2013 800205 MEF 
      XIF           * END RTE CODE
* 
      IFZ           * START RTE-M/L CODE
      NAM DLIST,19,30 91750-16073 REV 2013 800205 L/M2/M3 
      XIF           * END RTE-M/L CODE
      SPC 1 
******************************************************************
*  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  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.       *
******************************************************************
      SPC 2 
******************************************************* 
* 
*                   DIRECTORY LIST MONITOR FOR DS-1000
*                     IFN = RTE SYSTEMS 
*                     IFZ = RTE-M/L FLOPPY-BASED SYSTEMS
* 
*     NAME:         DLIST 
*     SOURCE:       91750-18072 ('IFN' VERSION) 
*     SOURCE:       91750-18072 ('IFZ' VERSION) 
*     RELOC:        91750-16072 ('IFN' VERSION) 
*     RELOC:        91750-16073 ('IFZ' VERSION) 
*     PGMR:         DAN GIBBONS 
* 
* 
*     MODIFIED BY:  GAB [790206] EIG REPLACEMENT WITH JSB'S 
*                   JDH [790220] DS REQUEST EQUATED OFFSETS 
* 
********************************************************
      SPC 2 
* 
*     PROGRAM TO DO DIRECTORY LISTING ON AS 
*     MANY REMOTE TERMINALS AS REQUIRED 
* 
* 
      ENT DLIST 
* 
      EXT EXEC,#SLAV,#GET,#NODE 
      EXT .MVW,.MBT,.LBT,.SBT 
      EXT .DRCT 
      EXT #RPB
RQB   EQU #RPB
* 
      IFN           * START RTE CODE
      EXT $CL1,$CL2,FSTAT,$BMON 
      EXT #ATCH,DTACH 
      XIF           * END RTE CODE
      IFZ           * START RTE-M/L CODE
      EXT $CDIR,$XECM,#IDAD,$OPSY 
      XIF           * END RTE-M/L CODE
* 
* 
A     EQU 0 
B     EQU 1 
      SUP 
      SPC 2 
* GLBLK-START 
* 
******************************************************************
*                                                                *
*     G L O B A L   B L O C K               REV XXXX 790531      *
*                                                                *
*     GLOBAL OFFSETS INTO DS/1000 MESSAGE BUFFERS, USED BY:      *
*                                                                *
*         REMAT, RFMST, DEXEC, DMESS, FLOAD, POPEN, #MAST        *
*         GET,   #SLAV, RQCNV, RPCNV, GRPM,  LSTEN, PTOPM        *
*         EXECM, EXECW, OPERM, RFAM1, RFAM2, DLIST, DLIS3        *
*                                                                *
******************************************************************
* 
***!!!!! THE FIRST 7 WORDS (#STR THRU #ENO) MUST BE FIXED !!!!!***
#STR  EQU 0         STREAM WORD.
#SEQ  EQU #STR+1    SEQUENCE NUMBER.
#SRC  EQU #SEQ+1    SOURCE NODE #.
#DST  EQU #SRC+1    DEST. NODE #. 
#EC1  EQU #DST+1    REPLY ECOD1.
#EC2  EQU #EC1+1    REPLY ECOD2.
#ENO  EQU #EC2+1    NUMBER OF NODE REPORTING ERROR. 
* 
#ECQ  EQU #ENO+1    ERROR CODE QUALIFIER (BITS 4 TO 7)
#LVL  EQU #ECQ      MESSAGE FORMAT LEVEL (BITS 0 TO 3)
#MAS  EQU #LVL+1    MA "SEND" SEQ. #
#MAR  EQU #MAS+1    MA "RECV" SEQ. #
#MAC  EQU #MAR+1    MA "CANCEL" FLAGS 
#HCT  EQU #MAC+1    HOP COUNT 
#SID  EQU #HCT+1    SESSION ID WORD 
* 
#EHD  EQU #SID      LAST ITEM OF HEADER 
#MHD  EQU #EHD+1    MINIMUM HEADER SIZE 
#REQ  EQU #MHD      START OF REQUEST SPECIFIC AREA
#REP  EQU #MHD      START OF REPLY SPECIFIC AREA
* 
#MXR  EQU #MHD+24   <<< MAXIMUM DS REQ/REPLY BUFFER SIZE >>>
#LSZ  EQU 2         <<< SIZE OF LOCAL APPENDAGE AREA >>>
* 
******************************************************************
* 
* GLBLK-END 
      SPC 3 
* 
* OFFSETS INTO DLIST REQUEST/REPLY BUFFER 
* 
STYP  EQU #STR         STREAM TYPE
STAT  EQU #REP         STATUS 
LNGH  EQU #REQ+1       LENGTH WORD
FLTR  EQU #REQ+3       NAME FILTER...0..NO FILTER 
MCODF EQU #REQ+6       MASTER SECURITY CODE 
CRLU  EQU #REQ+7       LU OF CART. TO DO
FTYP  EQU #REQ+8       FILE TYPE FILTER 
BROUT EQU #REQ+2       ADR OF NEXT PROCESS ROUTINE. 0=START 
WCLU  EQU #REP+9       CURRENT LU FOR DISK READ 
WTRCK EQU #REP+10      CURRENT TRACK TO READ
WSEC  EQU #REP+11      CURRENT SECTOR TO READ 
DISP  EQU #REP+12      DISPLACEMENT IN BUFFER 
SCTRK EQU #REP+13      # OF SECTORS/TRACK 
LUDSP EQU #REP+14      DISPLACEMENT IN DIRECTORY LU 
NTRKS EQU #REP+15      # OF DIRECTORY TRACKS
* 
* 
L#REQ ABS #REQ+16      REQUEST LENGTH 
L#REP EQU L#REQ        REPLY LENGTH 
      HED DLIST: MAIN * (C) HEWLETT-PACKARD CO. 1980
* 
*     MAIN ROUTINE STARTS HERE
* 
DLIST NOP 
      LDA B,I 
      STA CLSSN     SAVE  CLASS NUMBER
* 
      IFN           * START RTE CODE
INIT  LDA $BMON     CHECK TYPE OF SYSTEM
      SZA           PRE-RTE4B SYSTEM? 
      JMP NEWSY     NO, SETUP FOR NEW DRCTRY FRMT 
      LDA TATSD     YES, GET # TRKS IN SYS DISC 
      ADA M1        GET TO LAST TRACK 
      CLB           SET FOR SECTOR ZERO 
      JMP SETCD     GO SET CARTRIDGE DRCTRY DISC ADR
* 
CDTRK NOP           CARTRIDGE DRCTRY TRACK #
CDSEC NOP           CARTRIDGE DRCTRY SECTR #
* 
NEWSY JSB DTACH     (IN CASE 'DINIT' SCHEDULED FROM SESSION)
      DEF *+1 
* 
      LDA MSCA      ADJUST MSTR SEC CODE ADR
      ADA D128       FOR NEW CARTRIDGE DRCTRY 
      STA MSCA        FORMAT. 
      LDA DBFA1     ADJUST BUFR PTR TO
      ADA D128       2ND BLOCK OF CARTRIDGE 
      STA DBFAD       DIRECTORY BUFR. 
      LDA $CL1      GET CARTRIDGE DRCTRY TRK ADR
      LDB $CL2      GET SECTR ADR OF 2ND BLOCK
      ADB D2         OF CARTRIDGE DRCTRY. 
* 
SETCD STA CDTRK     SET DRCTRY TRK #
      STB CDSEC      AND SECTOR #.
      XIF           * END RTE CODE
      SPC 1 
DLST0 JSB #GET      DO A GET CALL 
      DEF *+6 
      DEF CLSSN 
      DEF RQB 
      DEF L#REQ 
      DEF D0        NO DATA 
      DEF D0
      JMP DLST0     IGNORE ERROR CALL 
* 
      LDA RQB+BROUT  GET ADDRESS OF CURRENT COROUTINE 
      SZA,RSS 
      JMP SUB1
      JMP A,I       GO TO SPECIFIED SUBROUTINE
      SPC 2 
SUB2A DEF SUB2
SUB3A DEF SUB3
SUB4A DEF SUB4
SUB5A DEF SUB5
SUB7A DEF SUB7
SUB9A DEF SUB9
SB10A DEF SUB10 
SB11A DEF SUB11 
DON1A DEF DONE1 
      SPC 5 
* 
*     HERE ON NEW REQUEST 
* 
SUB1  EQU * 
      IFN           * START RTE CODE
      LDA DBFA1     GET DIRECTORY DATA BUFR ADR 
      STA RQB+LUDSP  SAVE FOR LU LOOPING
SUB2  LDA D2        GET LU OF SYSTEM DISC 
      STA RQB+WCLU  SAVE AS WANTED LU 
      LDA CDTRK     GET CARTRIDGE DRCTRY TRACK #
      STA RQB+WTRCK  SAVE IN WANTED TRACK 
      LDB CDSEC     GET CARTRIDGE DRCTRY SECTOR # 
      STB RQB+WSEC  SAVE IN WANTED SECTOR 
      LDA DBFAD     READ 128 WORDS CONTAINING MSTR
      JSB GETSC      SECURITY CODE. 
* 
      LDA $BMON     CHECK SYSTEM TYPE 
      SZA,RSS       PRE-RTE4B SYSTEM? 
      JMP SUB2B     YES, DRCTRY & MSC ARE IN DBUF 
      LDA RQB+#SID  GET SESSION ID WORD FROM REQ. 
      AND RTBYT     ISOLATE DEST. SESSION ID (BITS 0-7) 
      STA TEMP      SAVE SESSION ID FOR '#ATCH' CALL
* 
      JSB #ATCH     ATTACH TO SESSION CONTROL BLOCK 
      DEF *+2 
      DEF TEMP
* 
      INA,SZA,RSS   CHECK FOR ERROR 
      JMP RSERR     "RS01" ERROR: SCB NOT FOUND 
* 
      JSB FSTAT     READ IN 253 WORD
      DEF *+3        CARTRIDGE DIRECTORY
      DEF DBUF        (IN OLD FORMAT).
      DEF D253
* 
      JSB DTACH     DETACH FROM SCB 
      DEF *+1 
* 
SUB2B LDA RQB+LUDSP,I  GET LU OF CARTRIDGE
      SZA,RSS       DONE? 
      XIF           * END RTE CODE
* 
      IFZ           * START RTE-M/L CODE
* 
      LDA M1        INITIALIZE VARIABLES TO ENSURE
      STA CTRCK       FRESH FILE DIRECTORY COPY 
      STA CSEC          IS READ AT LEAST ONCE.
      STA CCLU
* 
      JSB .DRCT     GET FLOPPY CARTRIDGE DIRECTORY ADR
      DEF $CDIR 
      STA RQB+LUDSP  SAVE FOR LU LOOPING
SUB2B EQU * 
SUB2  JSB .DRCT     GET ADR OF DIRECTORY
      DEF $CDIR 
      ADA M1        GET TO END-OF-DIRECTORY ADR 
      LDA A,I       GET THE ADDRESS 
      CPA RQB+LUDSP  DONE?
      JMP DONE      YES 
      LDA RQB+LUDSP,I  GET LU OF CARTRIDGE
      SZA           DONE OR $CDIR 
      CPA M2          NOT INITIALIZED?
      XIF           * END RTE-M/L CODE
* 
      JMP DONE      YES 
      LDA RQB+FLTR  IF FILTER-WORD #1 
      CPA M1         IS EQUAL TO A -1, THEN 
      JMP *+2         THIS IS A CARTRIDGE LIST REQUEST; 
      JMP SUB20        ELSE, PROCESS THE DIRECTORY LIST.
      LDA RQB+FLTR+1 IF FILTER-WORD #2
      SZA,RSS         IS EQUAL TO A 0, THEN 
      JMP SUB8         BEGIN THE CARTRIDGE LIST 
      JMP SUB10         ELSE, CONTINUE LISTING. 
SUB20 LDB RQB+BROUT  SEE IF FIRST TIME
      SZB 
      JMP SUB22     NOT FIRST TIME
      IFZ           * START RTE-M/L CODE
      LDA $XECM     GET RTE-M/L SECURITY CODE 
      STA MSCA,I    SAVE IT 
      XIF           * END RTE-M/L CODE
      CPB RQB+MCODF MSTR SECU SUPPLIED? (NOTE: <B>=0) 
      JMP SUB22     NONE--NO SPECIAL ACCESS.
      LDA MSCA,I    GET MASTER SECURITY CODE. 
      SZA,RSS       IF NONE, ALLOW ACCESS.
      JMP SUB22     NO SYS SECU CODE, SO ALLOW ACCESS 
* 
      IFN           * START RTE CODE
      LDB $BMON     CHECK TYPE OF SYSTEM
      SZB,RSS       PRE-RTE4B SYSTEM? 
      JMP NOMSK     YES, NO MASK ON MSTR SECU CODE
      XOR MASK      NO, SECU CODE IS ENCRYPTED
      INA           CONTINUE THE DECRYPTION 
NOMSK EQU * 
      XIF           * END RTE CODE
* 
      CPA RQB+MCODF  USER'S AND MASTER MATCH? 
      JMP SUB22     MATCH! ALLOW ACCESS.
      CLB           NO SPECIAL ACCESS ALLOWED, SO 
      STB RQB+MCODF  CLEAR MCODF. 
SUB22 LDA RQB+CRLU  DO THEY WANT A SPECIFIED LU?
      SZA,RSS       LU SUPPLIED?
      JMP MCR       NO
      LDB RQB+LUDSP  GET DISPLACEMENT 
      CMA,INA       ASSUME LU 
      SSA,RSS       IS IT LABEL?
      JMP SUB23     NO...LU 
      CMA,INA       YES...LABEL...MAKE POS AGAIN
      ADB D2        AND GET TO LABEL WORD 
SUB23 CPA B,I       IS LABEL OR LU MATCH? 
      JMP MCR       MATCH...PROCESS LU
      LDA RQB+LUDSP  NO MATCH GO TO NEXT ONE
      ADA D4
      STA RQB+LUDSP 
      JMP SUB2B 
      UNL 
      IFN           * START RTE CODE
MASK  DEC 31178 
      XIF           * END RTE CODE
      LST 
      SPC 5 
* 
*     ROUTINE TO PROCESS A MOUNTED CARTRIDGE
* 
      SPC 1 
MCR   LDA SUB5A     SET UP FOR RETURN AFTER SENDING THE LINE
      STA RQB+BROUT 
      LDA SECT2     GET # OF SECTORS IN TRACK 
      STA RQB+SCTRK SAVE IN SECTORS/TRACK 
      LDA RQB+LUDSP,I  GET LU OF DISK 
      STA RQB+WCLU  SAVE AS WANTED CURRENT LU 
      ISZ RQB+LUDSP  GET TO FIRST DIRECTORY TRACK 
      LDB RQB+LUDSP,I   GET DIRECTORY TRACK ADDRESS 
      STB RQB+WTRCK  SAVE TRACK ADDRESS 
      ISZ RQB+LUDSP  GET TO LOCK WORD 
      ISZ RQB+LUDSP 
      LDB RQB+LUDSP,I   GET LOCK WORD 
      ISZ RQB+LUDSP  GET TO NEXT ENTRY
      SZB           IS LU LOCKED
      JMP SUB2      YES 
* 
      IFN           * START RTE CODE
      LDB $BMON     CHECK SYSTEM TYPE 
      SZB           PRE-RTE4B SYSTEM? 
      JMP MCR01     NO
      CPA D2        YES, IS IT SYSTEM DISC? 
      LDB D14       YES 
      RSS 
MCR01 CLB 
      XIF           * END RTE CODE
* 
      STB RQB+WSEC  SAVE STARTING SECTOR ADDRESS
      LDA DBFA1     SET FOR ZERO DISPLACEMENT WITHIN BUFFER 
      JSB SCFX      GO GET SECTOR 
      JMP SUB2      NO FILE DIRECTORY 
      LDA RQB+DISP  GET NAME OF CART. 
      LDB CRNAA     GET DESTINATION ADDRESS 
      JSB .MVW      MOVE 3 WORDS
      DEF D3
      NOP 
      LDA CRNA      GET FIRST WORD OF CR NAME 
      RAL,CLE,ERA   GET RID OF SIGN BIT 
      STA CRNA      RESTORE 
      LDA RQB+DISP  GET TO LABEL WORD 
      ADA D3
      LDA A,I       CONVERT LABEL WORD TO ASC 
      JSB BNDEC 
      DEF LWA       LABEL WORD ADDRESS
      LDB RQB+DISP  GET TO # SEC/TRACK
      ADB D6
      LDA B,I       GET # OF SECTORS/TRACK
      STA RQB+SCTRK SAVE AS # OF SECTORS/TRACK
      ADB D2        GET TO # OF DIRECTORY TRACKS
      LDA B,I 
      ADA RQB+WTRCK  GET ENDING DIRECTORY TRACK 
      STA RQB+NTRKS 
      LDA B,I       GET # OF DIRECTORY TRACKS 
      CMA,INA       MAKE # POS. 
      JSB BNDEC     CONVERT TO ASC
      DEF DTRKA 
      LDA DTRKA+2   MOVE UP THE LEAST SIGNIFICANT DIGITS
      STA DTRKA      THEY ARE THE ONLY ONES TO BE PRINTED 
      LDA #NODE     IDENTIFY THE
      JSB BNDEC      NODE WHICH IS
      DEF NODE        BEING LISTED. 
      JSB WTLIN     SEND LINE TO TERMINAL 
      DEF HEAD1     FIRST HEADING LINE
      SPC 5 
* 
*     HERE AFTER FIRST HEADING LINE WRITTEN 
* 
SUB3  LDA SUB4A     GET ADDRESS WHERE TO GO NEXT TIME 
      STA RQB+BROUT 
      LDB D17       NON-SECURITY HEADER LENGTH. 
      LDA RQB+MCODF 
      SZA           SECURITY CODES BEING LISTED?
      LDB D20       YES, ADD "SCODE" TO HEADER
      STB HEAD2 
      JSB WTLIN     SEND OUT SEND HEADING LINE
      DEF HEAD2 
      SPC 5 
* 
*     HERE AFTER HEADING LINE WRITTEN 
*     JUST OUTPUT A BLANK LINE
* 
SUB5  LDA SUB3A     GET ADDRESS FOR NEXT TIME 
      STA RQB+BROUT 
      JSB WTLIN     SEND OUT BLANK LINE 
      DEF BLNKL 
      SPC 5 
* 
*     HERE TO START OUTPUTTING DIRECTORY
* 
SUB4  LDA RQB+DISP  GET FILE ENTRY
      ADA D16 
      JSB SCFX      SEE IF WE NEED NEW SECTOR 
      JMP SUB2      DONE...NO MORE DIRECTORY
      LDA RQB+DISP,I IS THIS FILE PURGED? 
      SSA 
      JMP SUB4      YES...GO TO NEXT ONE
      SZA,RSS       DONE? 
      JMP SUB6      YES...2 SPACES & GET NEXT LU
      JSB MDLIN     MOVE LINE IF IT PASSES THRU FILTER
      JMP SUB4      LINE FILTERED OUT. GET NEXT ENTRY 
      JSB WTLIN     GO WRITE THE LINE 
      DEF DLINA     ADDRESS OF DETAIL LINE
      SPC 5 
* 
*     HERE TO OUTPUT A BLANK LINE 
* 
SUB6  LDA SUB7A     GET ADDRESS FOR NEXT TIME 
      STA RQB+BROUT 
      JSB WTLIN     OUTPUT A BLANK LINE 
      DEF BLNKL 
      SPC 5 
* 
*     HERE TO OUTPUT A BLANK LINE 
* 
SUB7  LDA SUB2A     GET ADDRESS FOR NEXT TIME 
      STA RQB+BROUT 
      JSB WTLIN     OUTPUT A BLANK LINE 
      DEF BLNKL 
* 
*     HERE TO DO A CARTRIDGE LIST 
* 
SUB8  LDA SUB9A     GET ADDRESS FOR NEXT TIME.
      STA RQB+BROUT 
      LDA #NODE     IDENTIFY THE NODE 
      JSB BNDEC      WHOSE CARTRIDGE LIST 
      DEF CLNOD       IS BEING PROCESSED. 
      JSB WTLIN     OUTPUT THE
      DEF CLHED      CARTRIDGE-LIST HEADER. 
      SPC 2 
* 
*     HERE TO OUTPUT A SEPARATING BLANK LINE. 
* 
SUB9  LDA SB10A     GET ADDRESS FOR FIRST LINE
      STA RQB+BROUT  SET COROUTINE POINTER. 
      JSB WTLIN     OUTPUT A
      DEF BLNKL      BLANK LINE.
      SPC 2 
* 
*     PROCESS THE CARTRIDGE-LIST ENTRY. 
* 
SUB10 LDA RQB+LUDSP,I  GET THE CARTRIDGE LOGICAL UNIT.
      ISZ RQB+LUDSP  ADVANCE THE ENTRY-POINTER. 
      JSB BNDEC     CONVERT THE LU
      DEF DTYPA      TO IT'S ASCII EQUIVALENT.
      LDA DTYPA+2   GET THE TWO USEFUL ASCII DIGITS.
      STA LU        CONFIGURE THE LINE. 
      LDA RQB+LUDSP,I  GET LAST TRACK FOR THE CARTRIDGE.
      ISZ RQB+LUDSP  ADVANCE THE POINTER. 
      JSB BNDEC     CONVERT LAST TRACK TO ASCII,
      DEF LTRK       AND CONFIGURE THE LINE.
      LDA RQB+LUDSP,I  GET THE CARTRIDGE NUMBER.
      ISZ RQB+LUDSP  ADVANCE THE POINTER. 
      JSB BNDEC     CONVERT CARTRIDGE NO. TO ASCII, 
      DEF CART       AND CONFIGURE INTO MESSAGE.
      LDB CLEN1     PREPARE FOR UNLOCKED LINE LENGTH. 
      LDA RQB+LUDSP,I  GET LOCK FLAG (I.D. SEG. ADDR.)
      ISZ RQB+LUDSP  BUMP POINTER.
      SZA,RSS       IF IT'S NOT LOCKED, 
      JMP SNDLN      THEN COMPLETE THE LINE;
      ADA D12         ELSE, POINT TO PROGRAM NAME,
      CLE,ELA          AND FORM ITS BYTE ADDRESS. 
      LDB CLKBA     GET CONFIGURED MESSAGE BYTE ADDRESS.
      JSB .MBT      MOVE THE LOCKER'S NAME TO THE LINE. 
      DEF D5
      NOP 
      LDB CLEN2     GET LOCKED-CARTRIDGE LINE LENGTH. 
SNDLN STB CLINE     CONFIGURE THE LINE LENGTH.
      LDB SUB2A     SET FOR RETURN VIA RELOAD SECTION.
      LDA RQB+LUDSP,I  IF THE NEXT ENTRY
      SZA,RSS        IS NULL, THE LIST IS COMPLETE, SO
      LDB SB11A       SET RETURN TO WRAP-UP SECTION;
      STB RQB+BROUT    ESTABLISH THE COROUTINE POINTER. 
      STB RQB+FLTR+1 SET FLAG FOR CLIST CONTINUATION. 
      JSB WTLIN     SEND THE CONFIGURED LINE
      DEF CLINE      TO THE REMOTE NODE.
* 
SUB11 LDA DON1A     SEND A
      STA RQB+BROUT  BLANK LINE,
      JSB WTLIN       AND RETURN
      DEF BLNKL        TO THE END PROCESSOR.
* 
CLEN1 DEC 11
CLEN2 DEC 15
CLKBA DBL LOCK
* 
CLHED DEC 24
      ASC 14,  LU  LAST TRACK   CR   LOCK 
      ASC 7,  REMOTE NODE=
CLNOD ASC 3,
* 
CLINE NOP 
      ASC 1,
LU    ASC 1,
      ASC 2,
LTRK  ASC 3,
      ASC 1,
CART  ASC 3,
      ASC 1,
LOCK  ASC 3,
* 
      HED DLIST: ROUTINES * (C) HEWLETT-PACKARD CO. 1980
* 
*     SUBROUTINE TO MOVE DETAIL LINE TO PRINT LINE
*     CALLING SEQUENCE
*     JSB MDLIN 
*     NO MATCH RETURN...IE..FILTER MIS-MATCH,TYPE NO MATCH
*     NORMAL RETURN 
* 
      SPC 1 
MDLIN NOP 
      LDA RQB+FLTR  IS FILTER SPECIFIED 
      SZA           NO
      CPA SPACA     OR IS IT ALL SPACE? 
      JMP NDLN2     NOT SUPPLIED OR SPACE 
      JSB .DRCT     GET ADDRESS WHERE FILTER LOCATED
      DEF RQB+FLTR
      CLE,ELA       CONVERT TO BYTE ADDRESS 
      STA TEMP      SAVE FILTER BYTE ADDRESS
      LDA RQB+DISP  GET ADDRESS OF NAME 
      CLE,ELA       CONVERT TO BYTE ADDRESS 
      STA TEMP1     SAVE IN BYTE ADD COUNTER
      LDA M6        # OF CHAR IN FILTER 
      STA TEMP2     SAVE IN DOWN COUNTER
MDN11 LDB TEMP      GET BYTE ADD OF FILTER
      JSB .LBT      GET BYTE
      SZA,RSS       IF ZERO, CHANGE TO SPACE
      LDA C40       C40=SPACE 
      CPA FLTRC     IS IT A "-"?
      JMP MDN12     YES...DON'T CHECK 
      STA TEMP3     SAVE IN TEMP LOCATION 
      LDB TEMP1     GET BYTE ADDRESS OF NAME
      JSB .LBT      GET BYTE
      CPA TEMP3     IS THERE A MATCH? 
      RSS           YES 
      JMP MDLIN,I   NO...IGNORE ENTRY 
MDN12 ISZ TEMP      GET TO NEXT ENTRY 
      ISZ TEMP1 
      ISZ TEMP2     DONE? 
      JMP MDN11     NO
      SPC 1 
* 
*     AFTER CHECKING NAME, CHECK TYPE 
* 
NDLN2 LDB RQB+DISP  GET TO FILE TYPE
      ADB D3
      LDB B,I 
      LDA RQB+FTYP  CHECK WITH FILE TYPE PASSED 
      RAL,CLE,ERA     IS THERE A FILE TYPE? 
      SEZ           FILE TYPE SPECIFIED 
      CPA B         YES...DOES IT MATCH 
      RSS           MATCH...OR NO FILE TYPE SPECIFIED 
      JMP MDLIN,I   FILE TYPE NOT MATCHED 
      ISZ MDLIN     SET FOR NORMAL (P+2) RETURN.
      LDA DLLS      ESTABLISH LINE LENGTH 
      STA DLINA      FOR LINE SANS SECURITY CODE. 
      STB FTYPT     SAVE FILE TYPE, TEMPORARILY.
      LDA B         GET FILE TYPE FOR CONVERSION. 
      JSB BNDEC     CONVERT FILE TYPE TO ASC
      DEF DTYPA 
      LDA RQB+DISP  MOVE NAME TO OUTPUT LINE
      LDB ADNAM     GET DESTINATION ADDRESS 
      JSB .MVW      MOVE NAME 
      DEF D3
      NOP 
      LDA RQB+DISP  GET # OF SECTORS OR LU
      ADA D4        ASSUME LU 
      LDB FTYPT     SEE IF TYPE=0 
      SZB           YES?
      ADA D2        NO...GET # OF SECTORS 
      LDA A,I       GET VALUE 
      SZB,RSS       LU? 
      JMP CNVRT     YES, DON'T DIVIDE BY 2
      SSA           NEG BLOCK COUNT?
      CMA,INA,RSS   YES, MAKE POS & SKIP DIV BY 2 
      CLE,ERA       CONVERT TO # OF BLOCKS
CNVRT JSB BNDEC     CONVERT TO ASC
      DEF DBSLU 
      LDA BLNK4     BLANK OUT THE 
      LDB OPNAD      'OPEN TO' / EXTENT NO. 
      JSB .MVW         INFORMATION FIELD. 
      DEF D4
      NOP 
      LDA FTYPT     GET THE FILE TYPE.
      SZA,RSS       IF THE TYPE IS ZERO,
      JMP OPNFL      DON'T WORRY ABOUT EXTENTS. 
      LDB RQB+DISP  GET THE 
      ADB D5         EXTENT WORD
      CLE,ELB         FROM THE UPPER BYTE 
      JSB .LBT         OF THE DIRECTORY ENTRY.
      SZA,RSS       IF NOT AN EXTENT, THEN
      JMP OPNFL      CHECK THE OPEN FLAGS;
      JSB BNDEC       ELSE, CONVERT EXTENT NO., 
OPNAD DEF DXOPN        AND ADD IT TO THE LINE.
      LDA EXTBA     GET BYTE ADDR. OF EXTENT DELIMITER. 
      LDB EXNBA     GET BYTE ADDR. OF DELIMITER BUFFER. 
      JSB .MBT      MOVE '  +' TO CONFIGURED LINE.
      DEF D3
      NOP 
      JMP SCODP     IGNORE OPEN FLAGS FOR EXTENTS.
OPNFL LDA RQB+DISP  GET THE 
      ADA D9         OPEN FLAG
      LDA A,I         FROM THE ENTRY. 
* 
      IFZ           * START RTE-M/L CODE
      LDB $OPSY     CHECK OPSYS TYPE
      CPB M31       RTE-L?
      JSB #IDAD     YES, CONVERT OPEN-FLAG FORMAT 
      XIF           * END RTE-M/L CODE
* 
      IFN           * START RTE CODE
      LDB $BMON     CHECK SYSTEM TYPE 
      SZB,RSS       PRE-RTE4B SYSTEM? 
      JMP OPNF1     NO
      LDB A         YES, SAVE OPEN FLAG 
      AND BT15      ISOLATE OPEN FLAG 
      STA DTEMP     SAVE EXCLUSIVE BIT
      LDA B         RETRIEVE FLAG 
      AND RTBYT     ISOLATE ID SEG #
      SZA,RSS       IF FILE'S NOT OPENED, THEN
      JMP SCODP      IGNORE THIS ENTRY. 
      LDB KEYWD     CALCULATE POINTER 
      ADB M1         TO ID SEGMENT
      ADB A            ADDRESS. 
      LDA B,I       GET ID SEG ADR
      IOR DTEMP     INCLUDE EXCLUSIVE BIT 
      XIF           * END RTE CODE
* 
OPNF1 SZA,RSS       IF FILE'S NOT OPENED, THEN
      JMP SCODP      IGNORE THIS ENTRY. 
      CLE,ELA       SAVE EXCLUSIVE FLAG,
      ADA D24        AND FORM I.D. SEG WD#13 BYTE ADDRESS.
      LDB OPNBA     GET BYTE ADDR. FOR CONFIGURED LINE. 
      JSB .MBT      MOVE PROGRAM NAME INTO LINE.
      DEF D5
      NOP 
      LDA C55       IF IT IS EXCLUSIVE, THEN
      SEZ            USE ' -' AS A DELIMITER, AND 
      JSB .SBT        ADD THE DELIMITER TO THE LINE.
SCODP LDB RQB+MCODF  SUPPLY SECURITY CODE?
      SZB,RSS 
      JMP MDLIN,I    NO...RETURN. 
      LDA DLLWS     ESTABLISH LINE LENGTH 
      STA DLINA      FOR LINE WITH SECURITY CODE. 
      LDA RQB+DISP  GET THE 
      ADA D8         SECURITY CODE
      LDA A,I         FROM THE ENTRY. 
      JSB BNDEC     CONVERT TO ASCII, 
      DEF DSECA      AND CONFIGURE INTO LINE. 
      JMP MDLIN,I   RETURN. 
      SPC 1 
FTYPT NOP 
D5    DEC 5 
D9    DEC 9 
D12   DEC 12
D16   DEC 16
D20   DEC 20
DLLS  EQU D16 
DLLWS EQU D20 
D24   DEC 24
BLNK4 DEF BLNKL+1 
BLPLS ASC 2,  + 
EXTBA DBL BLPLS 
EXNBA DBL DXOPN 
OPNBA DBL DXOPN+1 
KEYWD EQU 1657B     KEYWORD BLOCK ADR 
RTBYT OCT 377 
BT15  OCT 100000
      SPC 5 
* 
*     HERE FOR REMOTE SESSION '#ATCH' ERROR 
* 
* 
      IFN           * START RTE CODE
RSERR DLD RS01      SET "RS01" INTO 
      STA RQB+#EC1   #EC1 & #EC2 OF 
      STB RQB+#EC2    REPLY.
      LDA #NODE     GET LOCAL NODE #
      IOR BT15      SET ASCII-ERROR BIT 
      STA RQB+#ENO  SET INTO REPLY
      JMP DONE1     GO RETURN TO USER 
* 
* 
RS01  ASC 2,RS01
      XIF           * END RTE CODE
* 
      SPC 5 
* 
*     HERE WHEN WE ARE ALL DONE 
* 
DONE  LDA RQB+BROUT  SEE IF WE SENT THEM ANYTHING 
      SZA 
      JMP DONE1     YES...JUST TERMINATE
      LDA DON1A     GET ADDRESS OF TERMINATION POINT
      STA RQB+BROUT 
      JSB WTLIN     SEND "DISK NOT MOUNTED" 
      DEF NOCRM 
* 
DONE1 CLA 
      STA RQB+LNGH  SET FOR NO DATA 
      LDA BIT14     TELL OTHER SIDE, ALL DONE 
      JMP TERM
      SPC 5 
* 
*     SUBROUTINE TO SEND DATA TO  REMOTE
*     CALLING SEQUENCE
*     JSB WTLIN 
*     DEF BUFFER
* 
*     BUFFER FORMAT:
*     LENGTH WORD, DATA BUFFER
* 
WTLIN NOP 
      LDA WTLIN,I   GET ADDRESS OF OUPUT LINE 
      INA           GET TO FIRST DATA WORD
      STA WTLNB 
      LDB WTLIN,I   GET LENGTH OF MESSAGE 
      LDB B,I 
      LDA RQB+LNGH  GET AVAILABLE LENGTH
      CMA,INA 
      ADA B         SEE IF THERE WAS TO MUCH ROOM 
      SSA           CHANGE LENGTH?
      STB RQB+LNGH  YES...SET IN CORRECT LENGTH 
* 
      CLA           SET FOR MORE TO COME
TERM  STA RQB+STAT  SAVE STATUS 
      LDA RQB+STYP  GET STREAM TYPE 
      IOR BIT14     SET FOR REPLY 
      STA RQB+STYP
      LDA #NODE 
      STA RQB+#ENO    SET STATUS LOCATION 
* 
      JSB #SLAV     SEND REPLY
      DEF *+4 
      DEF L#REP     REPLY LENGTH
WTLNB NOP           DATA ADDRESS
      DEF RQB+LNGH  DATA LENGTH 
* 
      NOP           IGNORE ERROR RETURN 
      JMP DLST0     GO DO A GET CALL
* 
      SPC 5 
* 
*     SUBROUTINE TO KEEP DISPLACEMENT ON DISK OK
*     CALLING SEQUENCE
*     JSB SCFX
*     NO MORE DIRECTORY TRACK RETURN
*     NORMAL RETURN 
*     A REG=DISPLACEMENT
*     UPON RETURN 
*     WILL UPDATE WTRCK,WSEC,AND DISP AS REQUIRED 
*     ASSUMES DISP STARTS WITH ADDRESS OF BUFFER
*     SCTRK MUST BE SET TO # OF SECTORS/TRACK 
*     IF TRACK CHANGES, NTRCK=LAST DIRECTORY TRACK-1
*     ALL SECTORS ARE ASSUMED TO BE 128 WORDS LONG
* 
      SPC 1 
SCFX  NOP 
      CMA,INA       NEGATE ADDRESS
      ADA DBFA1     GET DISPLACEMENT
      CMA,INA       MAKE IT POSITIVE
      CLB           CHECK IF OVERFLOW 
      DIV D128      CROSS A SECTOR BOUNDRY
      ADB DBFA1     GET DISPLACEMENT AS AN ADDRESS
      STB RQB+DISP  SAVE DISPLACEMENT ADDRESS 
      SZA,RSS       SECTOR CHANGE 
      JMP SCFXA     NO
      LDA D14       YES...GET TO NEXT SECTOR
      ADA RQB+WSEC  GET TO NEXT SECTOR ADDRESS
      CLB 
      DIV RQB+SCTRK  SEE IF WE HAVE LOOPED AROUND 
      STB RQB+WSEC  SAVE NEW SECTOR ADDRESS 
      SZA           IF NO ROLLOVER OR 
      SZB           NO NEW TRACK NEEDED 
      JMP SCFXA     DON'T UPDATE TRACK ADDRESS
      CCB           UPDATE TRACK ADDRESS
      ADB RQB+WTRCK  GET TO NEXT TRACK
      CPB RQB+NTRKS  DONE?
      JMP SCFX,I    YES 
      STB RQB+WTRCK  NO...SET IN NEW TRACK ADDRESS
SCFXA LDA DBFA1     DO A 128 WORD READ
      JSB GETSC 
      ISZ SCFX      GET TO RETURN 
      JMP SCFX,I    RETURN
      SPC 5 
* 
*     SUBROUTINE TO READ A PHYSICAL SECTOR (128 WORDS)
* 
*     CALLING SEQUENCE: 
* 
*        LDA <BUFR ADR> 
*        JSB GETSC
* 
*     THE FOLLOWING MUST BE SET UP: 
* 
*        WTRCK,WSEC,WCLU
* 
GETSC NOP 
      STA BUFAD     SAVE BUFFER ADR 
      LDA RQB+FLTR  IF A CARTRIDGE LISTING
      CPA M1         IS CURRENTLY IN PROGRESS,
      JMP GTSC1       FORCE A RELOAD OF THE SECTOR. 
      LDA RQB+WTRCK  GET CURRENT TRACK ADDRESS
      CPA CTRCK     SAME AS ONE WE GOT NOW? 
      RSS           YES 
      JMP GTSC1     NO...GO READ IT 
      LDA RQB+WSEC  IS IT THE SAME SECTOR 
      CPA CSEC      ? 
      RSS           YES 
      JMP GTSC1     NO...GO READ IT 
      LDA RQB+WCLU  SAME LU?
      CPA CCLU
      JMP GETSC,I   YES...DON'T READ SECTOR 
GTSC1 LDA RQB+WCLU  SET UP AS CURRENT 
      STA CCLU
* 
      IFZ           * START RTE-M/L CODE
      LDB $OPSY     CHECK SYSTEM TYPE 
      CPB M31       RTE-L?
      IOR C7700     YES, SET CONWD FOR DISC ACCESS
      XIF           * END RTE-M/L CODE
* 
      STA TEMP      SAVE CONWD FOR EXEC CALL
      LDA RQB+WTRCK 
      STA CTRCK 
      LDA RQB+WSEC
      STA CSEC
* 
      JSB EXEC      GO READ A SECTOR
      DEF *+7 
      DEF D1
      DEF TEMP      CONWD 
BUFAD NOP 
      DEF D128
      DEF RQB+WTRCK 
      DEF RQB+WSEC
      JMP GETSC,I   GOT SECTOR, RETURN
      SPC 2 
CTRCK OCT -1
CSEC  OCT -1
CCLU  OCT -1
BUFL  NOP 
      SPC 5 
* 
*     SUBROUTINE CONVERT BINARY TO ASCII DECIMAL
*     CALLING SEQUENCE
*     JSB BNDEC 
*     DEF BUFFER WHERE TO ASC 
*     A REG=BINARY #
* 
BNDEC NOP 
      STA DTEMP     SAVE BINARY # 
      LDB BNDEC,I   GET ADDRESS WHERE TO ASC
      CLE,ELB       CONVERT TO BYTE ADDRESS 
      STB DTMP1     SAVE BYTE ADDRESS 
      ISZ BNDEC     GET TO RETURN ADDRESS 
      LDA DNMA      GET ADDRESS OF DIVISORS 
      STA DTMP2     SAVE FOR DIVIDING 
      LDA M5        GET LOOP COUNT
      STA DTMP3     SAVE IN DOWN COUNTER
      LDA C40       GET A SPACE CHARACTERR
      LDB DTEMP     GET BINARY VALUE
      SSB,RSS       IF NEGATIVE...CONVERT 
      JMP BNDCB     NOT NEGATIVE
      CMB,INB       NEGATIVE, MAKE POSITIVE 
      STB DTEMP 
      LDA C55       SET IN NEG SIGN 
BNDCB LDB DTMP1     GET BYTE ADDRESS
      JSB .SBT      SAVE SIGN 
      ISZ DTMP1     GET NEXT BYTE ADDRESS 
BNDCA LDA DTEMP     GET BINARY #
      CLB           GET A ZERO
      DIV DTMP2,I 
      STB DTEMP     SAVE REMAINDER
      ADA C60       CONVERT TO ASC
      LDB DTMP1     GET CURRENT BYTE ADDRESS
      JSB .SBT      SAVE ASC BYTE 
      ISZ DTMP2     GET NEXT DIVISOR
      ISZ DTMP1     GET NEXT BYTE ADDRESS 
      ISZ DTMP3     DONE? 
      JMP BNDCA     NO
      JMP BNDEC,I   RETURN
      SPC 1 
C55   OCT 55
DTEMP NOP 
DTMP1 NOP 
DTMP2 NOP 
DTMP3 NOP 
DNMA  DEF DNM 
DNM   DEC 10000,1000,100,10,1 
C40   OCT 40
C60   OCT 60
C7700 OCT 7700
D3    DEC 3 
D8    DEC 8 
D14   DEC 14
D17   DEC 17
D128  DEC 128 
D4    DEC 4 
D1    EQU DNM+4     DEC 1 
D6    DEC 6 
D0    DEC 0 
D2    DEC 2 
M1    DEC -1
M2    DEC -2
M5    DEC -5
M6    DEC -6
BIT14 OCT 40000 
FLTRC EQU C55       "DON'T-CARE" FILTER CHAR (MINUS SIGN) 
TEMP  NOP 
TEMP1 NOP 
TEMP2 NOP 
TEMP3 NOP 
* 
TATSD EQU 1756B 
SECT2 EQU 1757B 
DBFA1 DEF DBUF
      IFN           * START RTE CODE
DBFAD DEF DBUF      MAY BE MODIFIED AT INIT 
D253  DEC 253 
      XIF           * END RTE CODE
MSCA  DEF DBUF+126  @MSC. MAY BE MODIFIED AT INIT 
CLSSN NOP 
CRNAA DEF CRNA
ADNAM DEF DNAMA 
      SPC 1 
* 
*     DEFINE OUTPUT LINE INFO 
* 
HEAD1 DEC 34
SPACA ASC 1,
      ASC 3,ILAB= 
CRNA  ASC 3,
      ASC 1,
      ASC 10,REMOTE DLIST: NODE=
NODE  ASC 3,
      ASC 1,
      ASC 2,CR#=
LWA   ASC 3,
      ASC 1,
      ASC 5,DIR TRKS= 
DTRKA ASC 3,
      SPC 1 
HEAD2 NOP 
      ASC 20,  NAME     TYPE  #BLKS/LU OPEN TO  SCODE 
      SPC 1 
NOCRM DEC 9 
      ASC 9,  DISK NOT MOUNTED
DLINA NOP 
      ASC 1,
DNAMA ASC 3,
      ASC 1,
DTYPA ASC 3,
      ASC 1 
DBSLU ASC 3,
DXOPN ASC 4,
      ASC 1,
DSECA ASC 3,
      SPC 2 
BLNKL DEC 1 
      OCT 20040,20040,20040,20040 
* 
DBUF  EQU * 
      IFN           * START RTE CODE
      BSS 256 
      XIF           * END RTE CODE
      IFZ           * START RTE-M/L CODE
      BSS 128 
M31   DEC -31 
      XIF           * END RTE-M/L CODE
      SPC 3 
END   EQU * 
      END DLIST 
                                                                                                                                                                                                              