/*SPLH*/ /*$TITLE='STATUS'     */
STAT:
DO;
 
/* COMMON STAT MODULE FOR MP/M-80 2.0 AND MP/M-86 2.0
                          CP/M-80 2.2 AND CP/M-86 1.1  */
 
/*
            COPYRIGHT(C) 1975, 1976, 1977, 1978, 1979, 1980, 1981,1982
            DIGITAL RESEARCH
            BOX 579
            PACIFIC GROVE, CA
            93950
 
            REVISED:
              20 JAN  80  BY THOMAS ROLANDER
              29 JULY 81  BY DOUG HUSKEY (FOR MP/M 2.0)
              02 SEPT 81  (FOR MP/M-86)
              14 NOV  81  BY DOUG HUSKEY (FOR CP/M-86)
              16 DEC  81  BY DOUG HUSKEY (FOR CP/M-86)
              31 JULY 82  BY H.CHAKI(FOR CP/M-68K)
  */
 
/* MODIFIED 10/30/78 TO FIX THE SPACE COMPUTATION */
/* MODIFIED 01/28/79 TO REMOVE DESPOOL DEPENDENCIES */
/* MODIFIED 07/26/79 TO OPERATE UNDER CP/M 2.0 */
/* MODIFIED 07/31/82 TO OPERATE UNDER CP/M-68K */
 
 /*  Command line to generate STAT.68K
 [[ assume that the all default VOLUME is SYS:0.. on EXORmacs]]
 
 (1)S-PL/H Compile and ASM on EXORmacs
    =SPLH STAT,,;A,S,X,NOV,NOF,MAR=1/80
    =SPLH STATSUB,,;A,S,X,NOV,NOF,MAR=1/80
    =ASM UT68K,,;
    [[ caution ]]
     STAT: main routine of STAT utility in S-PL/H
     STATSUB: sub routine of STAT utility in S-PL/H
     UT68K: standard interface routine in ASM
     A: assemble listing option
     S: symbol listing option
     X: xref listing option
     NOV: non save option
     NOF: non floatable option
     MAR: margin option [[ important ]]
 
  (2)LINK on EXORmacs
     =LINK STAT/STATSUB/UT68K,STAT68K,STAT68K;MIXRL=SPLHLIB.RO
     [[ caution ]]
     R option: generate relocatable object
 
  (3)XLINK on EXORmacs
     =XLINK STAT68K.RO,STAT68K.OX,O=STAT68K.OL
 
  (4)Convert file on EXORmacs to send to VAX
     =CONV STAT68K.OX,STAT68K.OC
 
  (5)Send to VAX from EXORMACS
     =VAX
     VAX command
     S
     Source file
     STAT68K.OC
 
  (6)Download to CP/M file from VAX
 
  (7)Re-convert file on CP/M
    A>RECONV
      input file :STAT68K.OC
      output file :STAT.68K
 
 
                           end command line                 */
 
        /* 
        NOTE:  IN AN ATTEMPT TO HAVE A COMMON SOURCE FOR 
        ALL DRI O.S. SHARED UTILITIES THE VERSION IS TESTED
        AND A NUMBER OF CONDITIONALLY EXECUTED STATEMENTS
        HAVE BEEN ADDED FOR COMPATIBILITY BETWEEN MP/M 2 
        AND CP/M.  THIS INCLUDES HANDLING BOTH R/O (UNDER
        CP/M AND RO).
        */
 
DECLARE
    BDOS3VER LITERALLY '30H'; /* TESTS FOR 3.0 CP/M BDOS */
 
/* SPLH */ DCL MEMORY(1028) BYTE EXT;
/* SPLH */
DECLARE
 /*SPLH*/  /* LIT LITERALLY 'LITERALLY',
              DCL LIT 'DECLARE',
              PROC LIT 'PROCEDURE',
              ADDR LIT 'ADDRESS',    */
        TRUE               LIT                '0FFH',
        FALSE              LIT                '0',
   /*   BOOLEAN            LIT                'BYTE',  */
        FOREVER            LIT                'WHILE TRUE',
        CR                 LIT                '13',
        LF                 LIT                '10',
        TAB                LIT                '9',
        FF                 LIT                '12',
        SECTORLEN          LIT                '128';
 
  /**************************************
   *                                    *
   *       B D O S   INTERFACE          *
   *                                    *
   **************************************/
 
 
  MON1:
    PROCEDURE (FUNC,INFO) EXTERNAL;
      DECLARE FUNC BYTE;
      DECLARE INFO ADDRESS;
    END MON1;
 
  MON2:
    PROCEDURE (FUNC,INFO) BYTE EXTERNAL;
      DECLARE FUNC BYTE;
      DECLARE INFO ADDRESS;
    END MON2;
 
  MON3:
    PROCEDURE (FUNC,INFO) ADDRESS EXTERNAL;
      DECLARE FUNC BYTE;
      DECLARE INFO ADDRESS;
    END MON3;
 
 MON5 : PROC(FN,IN)   EXT;
   DCL FN BYTE; DCL IN POINTER;
 END;
 MON6 : PROC(FN,IN) BYTE  EXT;
   DCL FN BYTE; DCL IN POINTER;
 END;
 MON7 : PROC(FN,IN) ADDR  EXT;
   DCL FN BYTE; DCL IN POINTER;
 END;
 
BASE$DPB: PROCEDURE EXTERNAL;     /* SET UP BASE OF DPB IN DPB86 */
END BASE$DPB;                     /* OR IN DPB80 MODULE          */
 
DPB$WORD: PROCEDURE (DPBINDEX) ADDRESS EXTERNAL;
  DECLARE DPBINDEX BYTE;
END DPB$WORD;
 
DPB$BYTE: PROCEDURE (DPBINDEX) BYTE EXTERNAL;
  DECLARE DPBINDEX BYTE;
END DPB$BYTE;
 
/*SPLH*/
/* INDICES INTO DISK PARAMETER BLOCK, USED AS PARAMETERS TO DPB PROCEDURE */
 
DCL        SPT$W        LIT        '0',
           BLKSHF$B     LIT        '2',
           BLKMSK$B     LIT        '3',
           EXTMSK$B     LIT        '4',
           BLKMAX$W     LIT      /*'5', */ '6',
           DIRMAX$W     LIT      /*'7', */ '8',
           DIRBLK$W     LIT      /*'9', */ '10',
           CHKSIZ$W     LIT      /*'11',*/ '12',
           OFFSET$W     LIT      /*'13';*/ '14';
 
        /* RETURNS THE NUMBER OF ALLOCATED BLOCKS IN THE 
           ALLOCATION VECTOR */
/*GET$ALL: PROCEDURE (DSM) ADDRESS EXTERNAL;
  DECLARE DSM ADDRESS;
END GET$ALL; */        /* S-PL/H */
 
        /* RETURNS THE NUMBER OF CRT COLUMNS */
COLUMNS: PROCEDURE BYTE EXTERNAL;
END COLUMNS;
 
 
 
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 
 
                    * * *  GLOBAL DATA  * * *
 
 
  * * * * * * * * * * * * * * * * * * * * * * * * * * * */
 
 
   /* BDOS INTERFACE */
 
/*  DECLARE CMDRV     BYTE    EXTERNAL;   /* COMMAND DRIVE      */
/* */ DECLARE FCB (100)   BYTE    EXTERNAL;   /* 1ST DEFAULT FCB    */
/* */ DECLARE FCB16 (100) BYTE    EXTERNAL;   /* 2ND DEFAULT FCB    */
/*  DECLARE PASS0     ADDRESS EXTERNAL;   /* 1ST PASSWORD PTR   */
/*  DECLARE LEN0      BYTE    EXTERNAL;   /* 1ST PASSWD LENGTH  */
/*  DECLARE PASS1     ADDRESS EXTERNAL;   /* 2ND PASSWORD PTR   */
/*  DECLARE LEN1      BYTE    EXTERNAL;   /* 2ND PASSWD LENGTH  */
/* */ DECLARE TBUFF (100) BYTE    EXTERNAL;   /* DEFAULT DMA BUFFER */
 
DECLARE
    MAXB  POINTER EXT , /*68K*/         /* ADDR FIELD OF JMP BDOS */
    MAXBL LONG AT(@MAXB), /*68K*/
    BUFF(128)BYTE EXTERNAL,             /* DEFAULT BUFFER */
    BUFFA LITERALLY '@BUFF',            /* DEFAULT BUFFER */
    FCBA  LITERALLY '@FCB',             /* DEFAULT FILE CONTROL BLOCK */
    DOLLA LITERALLY '@FCB(6DH-5CH)',    /* DOLLAR SIGN POSITION */
    PARMA LITERALLY '@FCB(6DH-5CH)',    /* PARAMETER, IF SENT */
    RRECA LITERALLY '@FCB(7DH-5CH)',    /* RANDOM RECORD 7D,7E,7F */
    RRECO LITERALLY '@FCB(7FH-5CH)',    /* HIGH BYTE OF RANDOM OVERFLOW */
    MEMSIZE LITERALLY 'MAXB',           /* END OF MEMORY */
    RREC ADDRESS AT(RRECA),             /* RANDOM RECORD ADDRESS */
    ROVF BYTE AT(RRECO),                /* OVERFLOW ON GETFILE */
    DOLL BYTE AT(DOLLA),                /* DOLLAR PARAMETER */
    PARM BYTE AT(PARMA);                /* PARAMETER */
 
 
 
    /* SEARCH AND SEARCH NEXT FCB */
 
DECLARE
/*68K*/ CHAKI (6) BYTE INIT (1,2,3,4,5,6),
        DCNT      BYTE,
        UFCB(14)  BYTE DATA('?????????????',0),  /* 68K */
        BFCBA     POINTER,               /* INDEX INTO DIR BUFFER */
/*68K*/ BFCBAL    LONG AT(@BFCBA),
        BFCBUSER  BASED BFCBA BYTE,
        BFCB      BASED BFCBA (32) BYTE; /* TEMPLATE OVER DIRBUFF */
 
    /* GENERAL GLOBALS */
 
DECLARE
    FCBMAX    LITERALLY '512',   /* MAX FCB COUNT */
    SPKSHF    LITERALLY '3',     /* 2**N SECTORS PER KBYTE */
    IOVAL     BYTE,              /* IO BYTE */
    SIZESET   BYTE INITIAL(0),   /* TRUE IF DISPLAYING SIZE FIELD */
    SET$ATTRIBUTE BYTE INITIAL(0), /* TRUE IF SETTING FILE ATTRIBUTES */
    USER$CODE BYTE,              /* CURRENT USER CODE */
    VER       ADDRESS,           /* OS VERSION NUMBER */
    KPB       ADDRESS,           /* KBYTES PER BLOCK */
    ALL$BLKS  ADDRESS,           /* NUMBER OF ALLOCATED BLOCKS */
    BDOS3     BYTE,              /* IS IT BDOS VERSION 3 ? */
    RODISK    ADDRESS,           /* READ ONLY DISK VECTOR */ 
    CDISK     BYTE;              /* CURRENT DISK */
 
DECLARE
    BYTE3     STRUCTURE (
        LWORD ADDRESS,
        HBYTE BYTE);
 
 
    /* SCANNER */
 
DECLARE
    ACCUM(4) BYTE,    /* ACCUMULATOR */
    IBP BYTE INITIAL(1);         /* INPUT BUFFER POINTER */
 
DECLARE
    DRIVENAME  (*) BYTE DATA 
        (' DRIVE ',0),
    READONLY   (*) BYTE DATA 
        ('READ ONLY (RO)',0),
    READWRITE  (*) BYTE DATA 
        ('READ WRITE (RW)',0),
    SYSTEM     (*) BYTE DATA 
        ('SYSTEM (SYS)',0),
    DIRECTORY  (*) BYTE DATA 
        ('DIRECTORY (DIR)',0),
    ENTRIES    (*) BYTE DATA 
        ('  DIRECTORY ENTRIES',0),
    FILENAME   (*) BYTE DATA 
        ('D:FILENAME.TYP ',0),
    USE        (*) BYTE DATA 
        ('USE: STAT ',0),
    INVALID    (*) BYTE DATA 
        ('INVALID ASSIGNMENT',0),
    SET$TO     (*) BYTE DATA 
        (' SET TO ',0),
    RECORD$MSG (*) BYTE DATA 
        ('128 BYTE RECORD',0),
    ATTRIBUTES (*) BYTE DATA 
        ('[RO] [RW] [SYS] OR [DIR]',0),
    DEVL       (*) BYTE DATA
        ('CON:AXI:AXO:LST:DEV:VAL:USR:DSK:'),
    ATTRIBL    (*) BYTE DATA
        ('RO  RW  SYS DIR SIZE');
 
 
 
    /* PRINT A 3 BYTE NUMBER */
 
DECLARE
    VAL (7) BYTE INITIAL(0,0,0,0,0,0,0),   /* BCD DIGITS    */
    FAC (7) BYTE INITIAL(0,0,0,0,0,0,0),   /* HIBYTE FACTOR */
/*68K*/F0  (7) BYTE DATA(6,3,5,5,6,0,0),   /*    65,536     */
/*68K*/F1  (7) BYTE DATA(2,7,0,1,3,1,0),   /*   131,072     */
/*68K*/F2  (7) BYTE DATA(4,4,1,2,6,2,0),   /*   262,144     */
/*68K*/F3  (7) BYTE DATA(8,8,2,4,2,5,0),   /*   524,288     */
/*68K*/F4  (7) BYTE DATA(6,7,5,8,4,0,1),   /* 1,048,576     */
/*68K*/F5  (7) BYTE DATA(2,5,1,7,9,0,2),   /* 2,097,152     */
/*68K*/F6  (7) BYTE DATA(4,0,3,4,9,1,4),   /* 4,194,304     */
/*68K*/PTR (7) POINTER DATA(@F0,@F1,@F2,@F3,@F4,@F5,@F6);
 
 
    /* DISPLAY FILES */
 
    DECLARE        /* DUPLICATE BLOCK DETECTION */
       LB BYTE INITIAL(1),                  /* NUMBER OF BYTES PER BLOCK # */
       FIRST$ERROR BYTE INITIAL(TRUE);      /* DUPLICATE BLOCK ERROR */  
 
    DECLARE        /* TOTALS */
       KBLKS  ADDRESS INITIAL(0),    /* TOTAL NUMBER OF 1K BLKS */
       NFCBS  ADDRESS INITIAL(0),    /* TOTAL NUMBER OF FCBS */
       NXFCBS ADDRESS INITIAL(0),    /* TOTAL NUMBER OF XFCBS */
       TALL   ADDRESS INITIAL(0);    /* TOTAL ALLOCATION */    
 
 
/*  END OF DATA SEGMENT */
 
DECLARE
        LAST$DSEG$BYTE BYTE INITIAL (0);
/* 68K */
  DCL DUMMYP POINTER,
      DUMMYL LONG AT(@DUMMYP);
  DCL DUM1P POINTER,
      DUM1L LONG AT(@DUM1P);
  DCL DUM2P POINTER,
      DUM2L LONG AT(@DUM2P);
 /* */
PLM: PROCEDURE PUBLIC;
 
 
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 
 
                * * *  PRIMITIVE FUNCTIONS  * * *
 
 
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
 
 
 
BOOT: PROCEDURE;
    CALL MON1 (0,0);  /* SYSTEM RESET */
    END BOOT;
 
PRINTCHAR: PROCEDURE(CHAR);
    DECLARE CHAR BYTE;
    CALL MON1(2,CHAR);
    END PRINTCHAR;
 
PRINTB: PROCEDURE;
    /* PRINT BLANK CHARACTER */
    CALL PRINTCHAR(' ');
    END PRINTB;
 
BLANKS: PROCEDURE(B);
    DECLARE B BYTE;
        DO WHILE (B:=B-1) <> -1;
        CALL PRINTB;
        END;
    END BLANKS;
 
PRINTX: PROCEDURE(A);
    DECLARE A POINTER;
    DECLARE S BASED DUMMYP BYTE;
   /*68K*/ DUMMYP=A;
        DO WHILE S <> 0;
        CALL PRINTCHAR(S);
  /*68K*/ DUMMYL=DUMMYL+1;
        END;
    END PRINTX;
 
IOVALF: PROCEDURE BYTE;
   RETURN MON2(7,0);  /*  GET I/O BYTE */
   END IOVALF;
  
SIOVALF: PROCEDURE(VALUE);
    DECLARE VALUE BYTE;
    CALL MON1(8,VALUE);    /* SET IOBYTE  */
    END SIOVALF;
  
BREAK: PROCEDURE BYTE;
    RETURN MON2(11,0); /* CONSOLE READY */
    END BREAK;
  
TEST$BREAK: PROCEDURE;
 
    IF BREAK THEN
        DO; 
        CALL MON1 (1,0);  /* READ CHARACTER */
        CALL PRINTX(@(CR,LF,'** ABORTED **',0));
        CALL BOOT;
        END;
    END TEST$BREAK;
 
CRLF: PROCEDURE;
    CALL PRINTCHAR(CR);
    CALL PRINTCHAR(LF);
    CALL TEST$BREAK;
    END CRLF;
 
PRINT: PROCEDURE(A);
    DECLARE A POINTER;
    /* PRINT THE STRING STARTING AT ADDRESS A UNTIL THE
    NEXT 0 IS ENCOUNTERED */
    CALL CRLF;
    CALL PRINTX(A);
    END PRINT;
 
  VERSION: PROCEDURE ADDRESS;
    /* RETURNS CURRENT CP/M VERSION # */
    RETURN MON3(12,0);
    END VERSION;
 
GETRODISK: PROCEDURE ADDRESS;
    /* GET THE READ-ONLY DISK VECTOR */
    RETURN MON3(29,0);
    END GETRODISK;
 
SELECT: PROCEDURE(D);
    DECLARE D BYTE;
    RODISK = GETRODISK; /* READ ONLY DISK VECTOR SET */
    CDISK = D;
    CALL MON1(14,D);
    END SELECT;
 
OPEN: PROCEDURE(FCB);
    DECLARE FCB POINTER;
    DCNT = MON6(15,FCB);
    END OPEN;
 
SEARCH: PROCEDURE(FCB);
    DECLARE FCB POINTER;
    DECLARE FCB0 BASED FCB BYTE;
    DCNT = MON6(17,FCB);
    END SEARCH;
 
SEARCHN: PROCEDURE;
    DCNT = MON2(18,0);
    END SEARCHN;
 
CSELECT: PROCEDURE BYTE;
    /* RETURN CURRENT DISK NUMBER */
    RETURN MON2(25,0);
    END CSELECT;
 
SETDMA: PROCEDURE(DMA);
    DECLARE DMA POINTER;
    CALL MON5(26,DMA);
    END SETDMA;
 
GETLOGIN: PROCEDURE ADDRESS;
    /* GET THE LOGIN VECTOR */
    RETURN MON3(24,0);
    END GETLOGIN;
 
WRITEPROT: PROCEDURE;
    /* WRITE PROTECT THE CURRENT DISK */
    CALL MON1(28,0);
    END WRITEPROT;
 
SETIND: PROCEDURE(A);
    DECLARE A POINTER;
    /* SET FILE INDICATORS FOR CURRENT FCB */
    CALL MON5(30,A);
    END SETIND;
 
GETUSER: PROCEDURE BYTE;
    /* RETURN CURRENT USER NUMBER */
    RETURN MON2(32,0FFH);
    END GETUSER;
 
SETUSER: PROCEDURE(USER);
    DECLARE USER BYTE;
    CALL MON1(32,USER);
    END SETUSER;
 
 
GETFILESIZE: PROCEDURE(FCB);
    DECLARE FCB POINTER;
    CALL MON5(35,FCB);
    END GETFILESIZE;
 
 
GETFREESP: PROCEDURE(D);
    DECLARE D BYTE;
 
    CALL MON1(46,D);
    END GETFREESP;
 
/* WE WANT KPB (KBYTES PER BLOCK) SO THAT EACH TIME WE FIND
   A BLOCK ADDRESS WE CAN ADD KPB K TO THE KILOBYTE ACCUMULATOR
   FOR FILE SIZE.  WE DERIVE KPB AS FOLLOWS:
 
    BLKSHF        RECS/BLK        K/BLK        BLKSHF-3
 
      3               8             1              0
      4              16             2              1
      5              32             4              2
      6              64             8              3
      7             128            16              4
                                                                */
 
SET$KPB: PROCEDURE;
    DECLARE KSHF BYTE;
 
    CALL BASE$DPB; /* DISK PARAMETERS SET */
    IF (KSHF:=DPB$BYTE(BLKSHF$B)-SPKSHF) < 1 THEN
        KPB = 1;
    ELSE
        KPB = SHL(DOUBLE(1),DPB$BYTE(BLKSHF$B)-SPKSHF); 
    END SET$KPB;
 
SELECT$DISK: PROCEDURE(D);
    DECLARE D BYTE;
    /* SELECT DISK AND SET KPB */
    CALL SELECT(D);
    CALL SET$KPB; /* BYTES PER BLOCK */
    END SELECT$DISK;
 
/* 68K*/
 MOVE : PROC(C,S,D);
   DCL C BYTE,(S,D) POINTER;
   DCL A BASED DUM1P BYTE,B BASED DUM2P BYTE;
     DUM1P=S; DUM2P=D;
    DO WHILE (C:=C-1)<>255;
     B=A;
     DUM1L=DUM1L+1; DUM2L=DUM2L+1;
    END;
  END;
 
 
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 
 
                    * * *  SCANNER  * * *
 
 
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
 
 
 
                  /* FILL STRING @ S FOR C BYTES WITH F */
FILL:   PROC(S,F,C);
    DCL S POINTER,C ADDR,
        F BYTE,
        A BASED DUMMYP BYTE;
/*68K*/ DUMMYP=S;
        DO WHILE (C:=C-1)<>0FFFFH;
        A = F;
/*S8K*/ DUMMYL=DUMMYL+1;
        END;
    END FILL;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* GET NEXT INPUT VALUE INTO ACCUM */
SCAN: PROCEDURE;
    /* FILL ACCUM WITH NEXT INPUT VALUE */
    DECLARE (I,B) BYTE;
    SETACC: PROCEDURE(B);
        DECLARE B BYTE;
        IF I < 4 THEN 
            ACCUM(I) = B;
        I = I + 1;
        END SETACC;
 
    /* DEBLANK INPUT */
        DO WHILE (B:=BUFF(IBP)) = ' ';
        IBP = IBP + 1;
        END;
    /* SKIP OPTION DELIMITER */
    IF B = '[' THEN
        IBP = IBP + 1;
    /* INITIALIZE ACCUM LENGTH (0-3) */
    I = 0;
    CALL FILL(@ACCUM,' ',4);
        DO WHILE (B := BUFF(IBP)) > 1;
        IF B < '!' OR B = ',' OR B = ':' OR
           B = '[' OR B = '=' THEN BUFF(IBP) = 1;
        ELSE
            IBP = IBP + 1;
        IF B <> '/' AND B <> '$' AND B <> ']' AND B <> ','
            THEN CALL SETACC(B);
        END;
    IF B <> 0 THEN 
        IBP = IBP + 1;
    END SCAN;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* PARSE AN ASSIGNMENT INTO ACCUMULATOR */
PARSE$ASSIGN: PROCEDURE BYTE;
    DCL B BYTE;
    
    CALL SCAN;
    IF ACCUM(0) <> '=' THEN
        RETURN FALSE;
    CALL SCAN; 
    RETURN TRUE;
    END PARSE$ASSIGN;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* PARSE NEXT ITEM INTO ACCUMULATOR */
PARSE$NEXT: PROCEDURE BYTE;
 
    CALL SCAN;
    IF ACCUM(0) = ' ' THEN DO;
        CALL SCAN;
        IF ACCUM(0) = ' ' THEN
            RETURN FALSE;
        END;
    RETURN TRUE;
    END PARSE$NEXT;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* PRINT A DECIMAL NUMBER FROM 2 BYTE BINARY 
                     IN A FIXED FIELD (PRECISION) */
PDECIMAL: PROCEDURE(V,PREC);
    /* PRINT VALUE V WITH PRECISION PREC (10,100,1000)
    WITH LEADING ZERO SUPPRESSION */
    DECLARE
        V ADDRESS,    /* VALUE TO PRINT */
        PREC ADDRESS, /* PRECISION */
        ZEROSUP BYTE, /* ZERO SUPPRESSION FLAG */
        D BYTE;       /* CURRENT DECIMAL DIGIT */
    ZEROSUP = TRUE;
        DO WHILE PREC <> 0;
        D = V / PREC ; /* GET NEXT DIGIT */
        V = V MOD PREC;/* GET REMAINDER BACK TO V */
        PREC = PREC / 10; /* READY FOR NEXT DIGIT */
        IF PREC <> 0 AND ZEROSUP AND D = 0 THEN CALL PRINTB; ELSE
            DO; ZEROSUP = FALSE; CALL PRINTCHAR('0'+D);
            END;
        END;
    END PDECIMAL;
 
 
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 
 
                   * * *  PRINT A NUMBER  * * *
 
 
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
 
 
 
                  /* BCD - CONVERT 16 BIT BINARY TO 
                     7 ONE BYTE BCD DIGITS */
BCD: PROCEDURE(VALUE);
    DECLARE
        (VALUE,PREC) ADDRESS,
        I BYTE;
 
    PREC = 10000;
    I = 5;                            /* DIGITS: 4,3,2,1,0 */
        DO WHILE PREC <> 0;
      /* S-PL/H */ I=I-1;
        VAL(I) = VALUE / PREC;   /* GET NEXT DIGIT */
        VALUE = VALUE MOD PREC;       /* REMAINDER IN VALUE */
        PREC = PREC / 10;
        END;
    END BCD;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* PRINT BCD NUMBER IN VAL ARRAY */
PRINTBCD: PROCEDURE(FIXED);
   DECLARE 
       (FIXED, ZEROSUP, I) BYTE;
 
   PCHAR: PROCEDURE(C);
       DECLARE C BYTE;
       IF VAL(I) = 0 THEN
           IF ZEROSUP THEN 
               IF I <> 0 THEN DO;
                   IF FIXED THEN
                       CALL PRINTB;
                   RETURN;
                   END;
       /* ELSE */
       CALL PRINTCHAR(C);
       ZEROSUP = FALSE;
   END PCHAR;
 
   ZEROSUP = TRUE;
   I = 7;
       DO WHILE (I:=I-1) <> -1;
       CALL PCHAR('0'+VAL(I));
       IF I = 6 OR I = 3 THEN 
           CALL PCHAR(',');
       END;
   END PRINTBCD;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* ADD TWO BCD NUMBERS RESULT IN SECOND */
ADD: PROCEDURE(AP,BP);
    DECLARE
        (AP,BP)        POINTER,
        A BASED AP (7) BYTE,
        B BASED BP (7) BYTE,
        (C,I)          BYTE;
 
    C = 0;                               /* CARRY   */
        DO I = 0 TO 6;                   /* 0 = LSB */
        B(I) = A(I) + B(I) + C;
        C = B(I) / 10;
        B(I) = B(I) MOD 10;
        END;
    END ADD;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 P3BYTEL : PROC(BYTE3ADR,FIXED);   /* S-PL/H */
   DCL BYTE3ADR POINTER,
       FIXED BYTE,
       B3 BASED BYTE3ADR (3) BYTE, L1 LONG,PREC LONG,
       I BYTE;
    L1=(LINT(B3(0))*256+LINT(B3(1)))*256+LINT(B3(2));
    PREC=1000000;   I=7;
    DO WHILE PREC<>0;
      I=I-1;
      VAL(I)=L1/PREC; L1=L1 MOD PREC; PREC=PREC/10;
    END;
    CALL PRINTBCD(FIXED);
  END;             /* S-PL/H */
                  /* PRINT 3 BYTE VALUE BASED AT BYTE3ADR */
P3BYTE: PROCEDURE(BYTE3ADR,FIXED);
   DECLARE
      FIXED     BYTE,
      I         BYTE,  
      HIGH$BYTE BYTE,
      BYTE3ADR  POINTER,
      B3 BASED  BYTE3ADR STRUCTURE (
          LWORD ADDRESS,
          HBYTE BYTE);
 
    CALL FILL(@VAL,0,7);
    CALL FILL(@FAC,0,7);
    CALL BCD(B3.LWORD);         /* PUT 16 BIT VALUE IN VAL */
    HIGH$BYTE = B3.HBYTE;
        DO I = 0 TO 6;                 /* FACTOR FOR BIT I */
        IF HIGH$BYTE THEN              /* LSB IS 1 */
            CALL ADD(PTR(I),@FAC);     /* ADD IN FACTOR */
        HIGH$BYTE = SHR(HIGH$BYTE,1);  /* GET NEXT BIT  */
        END;
    CALL ADD(@FAC,@VAL);              /* ADD FACTOR TO VALUE */
    CALL PRINTBCD(FIXED);             /* PRINT VALUE */
    END P3BYTE;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* DIVIDE 3 BYTE VALUE BY 8 */
SHR3BYTE: PROCEDURE(BYTE3ADR);
      DCL BYTE3ADR POINTER,
          B3 BASED BYTE3ADR STRUCTURE (
          LWORD ADDRESS,
          HBYTE BYTE),
          TEMP1 BASED BYTE3ADR (2) BYTE,
          TEMP2 BYTE;
 
 /*     TEMP2  = ROR(B3.HBYTE,3) AND 11100000B;  /* GET 3 BITS */
 /*     B3.HBYTE = SHR(B3.HBYTE,3);
        B3.LWORD = SHR(B3.LWORD,3);
        TEMP1(1) = TEMP1(1) OR TEMP2;   /* OR IN 3 BITS FROM HBYTE */
 /* 68K */
         B3.LWORD=B3.LWORD/8 OR SHL(UNSIGN(B3.HBYTE) AND 7, 13);
         B3.HBYTE=SHR(B3.HBYTE,3);
        END SHR3BYTE;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* MULTIPLY 3 BYTE VALUE BY #RECORDS PER BLOCK */
SHL3BYTE: PROCEDURE(BYTE3ADR);
       DCL BYTE3ADR POINTER,
           B3 BASED BYTE3ADR STRCT(
          LWORD ADDRESS,
          HBYTE BYTE),
          TEMP1 BASED BYTE3ADR (2) BYTE;
 
   /*   B3.HBYTE = (ROL(TEMP1(1),DPB$BYTE(BLKSHF$B)) AND DPB$BYTE(BLKMSK$B))
          OR SHL(B3.HBYTE,DPB$BYTE(BLKSHF$B));
        B3.LWORD = SHL(B3.LWORD,DPB$BYTE(BLKSHF$B));       */
   /* 68K */
        B3.HBYTE=SHR(B3.LWORD,16-DPB$BYTE(BLKSHF$B));
        B3.LWORD=SHL(B3.LWORD,DPB$BYTE(BLKSHF$B));
        END SHL3BYTE;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* DISPLAY CURRENT DRIVE */
SHOW$DRV: PROCEDURE;
    CALL PRINTCHAR(CDISK+'A');
    CALL PRINTCHAR(':');
    END SHOW$DRV;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* DISPLAY CURRENT DRIVE WITH SPACE */
SHOW$DRIVE: PROCEDURE;
    CALL SHOW$DRV;
    CALL PRINTB;
    END SHOW$DRIVE;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* PRINT USER NUMBER */
SHOW$USR: PROCEDURE(USER);
    DCL USER BYTE;
 
    CALL PRINTX(@('USER :',0));
    CALL PDECIMAL(USER,100);
    END SHOW$USR;
 
 
 
 
 
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 
 
         * * *  CP/M 2 BLOCK COUNTING ROUTINES  * * *
 
 
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
 
 
                  /* ADD # OF KILOBYTES IN ONE BLOCK 
                     KPB = KILOBYTES PER BLOCK       */
ADD$BLOCK: PROCEDURE(AK);
    DECLARE AK POINTER;
    /* ADD ONE BLOCK TO THE KILOBYTE ACCUMULATOR */
    DECLARE KACCUM BASED AK ADDRESS; /* KILOBYTE ACCUM */
 
    KACCUM = KACCUM + KPB;
    END ADD$BLOCK;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* RETURNS THE NUMBER OF K REMAINING */
COUNT: PROCEDURE ADDRESS;
    DECLARE
        KA  ADDRESS,  /* KB ACCUMULATOR */
        (I, MAXALL)   ADDRESS;  /* LOCAL INDEX */
    DCL  LCOUNT LONG;  /* 68K */
/*  KA = 0;
    ALL$BLKS = GETALL(DPB$WORD(BLKMAX$W));
    IF (MAXALL:=DPB$WORD(BLKMAX$W)) > ALL$BLKS THEN
        DO I = 0 TO MAXALL-ALL$BLKS;
        CALL ADD$BLOCK(@KA);
        END; 
    RETURN KA;  */
/* 68K */
     CALL SETDMA(@LCOUNT);
     CALL MON1(46,UNSIGN(CDISK)) ;   /* GET DISK FREE SPACE */
     RETURN LCOUNT/8; /* K BYTE */
    END COUNT;
 
 
 
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 
 
                 * * *  STATUS ROUTINES  * * *
 
 
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
 
 
                  /* DISPLAY DRIVE CHARACTERISTICS */
DRIVESTATUS: PROCEDURE;
      DCL B3A POINTER,
          B3 BASED B3A STRUCTURE (
             LWORD ADDRESS,
             HBYTE BYTE);
 
         /* PRINT 3 BYTE VALUE */
    PV3: PROCEDURE;
         CALL CRLF;
         CALL P3BYTE(B3A,TRUE);
         CALL PRINTCHAR(':');
         CALL PRINTB;
         END PV3;
 
         /* PRINT ADDRESS VALUE V */
     PV: PROCEDURE(V);
         DCL V ADDRESS;
         B3.HBYTE = 0;
         B3.LWORD = V;
         CALL PV3;
         END PV;
 
    /* PRINT THE CHARACTERISTICS OF THE CURRENTLY SELECTED DRIVE */
    B3A = @BYTE3;
    CALL PRINT(@('        ',0));
    CALL SHOW$DRIVE;
    CALL PRINTX(@('DRIVE CHARACTERISTICS',0));
    B3.HBYTE = 0;
    B3.LWORD = DPB$WORD(BLKMAX$W) + 1;       /* = # BLOCKS */
    CALL SHL3BYTE(B3A);        /* # BLOCKS * RECORDS/BLOCK */
    CALL PV3;
    CALL PRINTX(@RECORD$MSG);
    CALL PRINTX(@(' CAPACITY',0));
    CALL SHR3BYTE(B3A);        /* DIVIDE BY 8 */
    CALL PV3;
    CALL PRINTX(@('KILOBYTE DRIVE  CAPACITY',0));
    CALL PV(DPB$WORD(DIRMAX$W)+1);
    CALL PRINTX(@('32 BYTE',0));
    CALL PRINTX(@ENTRIES);
    CALL PV(SHL(DPB$WORD(CHKSIZ$W),2));
    CALL PRINTX(@('CHECKED',0));
    CALL PRINTX(@ENTRIES);
    CALL PV((DPB$BYTE(EXTMSK$B)+1) * 128);
    CALL PRINTX(@RECORD$MSG);
    CALL PRINTX(@('S / DIRECTORY ENTRY',0));
    CALL PV(SHL(DOUBLE(1),DPB$BYTE(BLKSHF$B)));
    CALL PRINTX(@RECORD$MSG);
    CALL PRINTX(@('S / BLOCK',0));
    CALL PV(DPB$WORD(SPT$W));
    CALL PRINTX(@RECORD$MSG);
    CALL PRINTX(@('S / TRACK',0));
    CALL PV(DPB$WORD(OFFSET$W));
    CALL PRINTX(@('RESERVED  TRACKS',0));
    CALL CRLF;
    END DRIVESTATUS;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* DISPLAY ACTIVE USER NUMBERS */
USERSTATUS: PROCEDURE;
    /* DISPLAY ACTIVE USER NUMBERS */
    DECLARE I BYTE;
    DECLARE USER(16) BYTE;
    CALL CRLF;
    CALL SHOW$DRIVE;
    CALL PRINTX(@('ACTIVE ',0));
    CALL SHOW$USR(USER$CODE);
    CALL CRLF;
    CALL SHOW$DRIVE;
    CALL PRINTX(@('ACTIVE FILES:',0));
        DO I = 0 TO LAST(USER);
        USER(I) = FALSE;
        END;
    CALL SETDMA(@MEMORY);
    CALL SEARCH(@UFCB);
        DO WHILE DCNT <> 255;
        IF (I := MEMORY(SHL(DCNT AND 11B,5))) <> 0E5H THEN
            USER(I AND 0FH) = TRUE;
        CALL SEARCHN;
        END;
        DO I = 0 TO LAST(USER);
        IF USER(I) THEN CALL PDECIMAL(I,100);
        END;
    CALL CRLF;
    END USERSTATUS;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* DISPLAY STATUS OF LOGGED IN DISKETTES */
DISKSTATUS: PROCEDURE;
    /* DISPLAY DISK STATUS */
    DECLARE LOGIN ADDRESS, D BYTE;
    LOGIN = GETLOGIN; /* LOGIN VECTOR SET */
    D = 0;
        DO WHILE LOGIN <> 0;
        IF LOW(LOGIN) THEN
            DO; CALL SELECT$DISK(D);
            CALL DRIVESTATUS;
            END;
        LOGIN = SHR(LOGIN,1);
        D = D + 1;
        END;
    END DISKSTATUS;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* TRY TO MATCH 4 CHARACTER DEVICE IN 
                     ACCUM WITH DEVICE IN LIST 
                            VA = ADDRESS OF LIST
                            V1 = # OF DEVICES IN LIST */
MATCH: PROCEDURE(VA,VL) BYTE;
    /* RETURN INDEX+1 TO VECTOR AT VA IF MATCH */
    DECLARE VA POINTER,
        V BASED VA (16) BYTE,
        VL BYTE;
    DECLARE (I,J,MATCH,SYNC) BYTE;
    J,SYNC = 0;
        DO SYNC = 1 TO VL;
        MATCH = TRUE;
            DO I = 0 TO 3;
            IF V(J) <> ACCUM(I) THEN MATCH=FALSE;
            J = J + 1;
            END;
        IF MATCH THEN RETURN SYNC;
        END;
    RETURN 0; /* NO MATCH */
    END MATCH;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* PROCESS A DEVICE REQUEST VALID DEVICES 
                     ARE LISTED ABOVE  */
DEVREQ: PROCEDURE BYTE;
    /* PROCESS DEVICE REQUEST, RETURN TRUE IF FOUND */
    /* DEVICE TABLES */
    DECLARE
        DEVR(*) BYTE DATA
        (/* CONSOLE */ 'TTY:CRT:BAT:UC1:',
         /* READER  */ 'TTY:PTR:UR1:UR2:',
         /* PUNCH   */ 'TTY:PTP:UP1:UP2:',
         /* LISTING */ 'TTY:CRT:LPT:UL1:');
 
    DECLARE
        (I,J,IOBYTE,ITEMS,IOVAL) BYTE;
 
 
    PRNAME: PROCEDURE(A);
        DECLARE A POINTER,
            X BASED DUMMYP BYTE;
 /*68K*/ DUMMYP=A;
        /* PRINT DEVICE NAME AT A */
            DO WHILE X <> ':';
            CALL PRINTCHAR(X); DUMMYL=DUMMYL+1;
            END;
        CALL PRINTCHAR(':');
        END PRNAME;
 
    DEVSTATUS: PROC;
        IOBYTE = IOVALF; J = 0;
    /*68K*/ CALL CRLF;
            DO I = 0 TO 3;
            CALL PRNAME(@DEVL(SHL(I,2)));
            CALL PRINTX(@(' IS ',0));
            CALL PRNAME(@DEVR(SHL(IOBYTE AND 11B,2)+J));
            J = J + 16; IOBYTE = SHR(IOBYTE,2);
            CALL CRLF;
            END;
        END DEVSTATUS; 
 
    VALUES: PROCEDURE;
        CALL PRINT(@('STAT 2.2',0));
        CALL CRLF;
        CALL PRINT(@('READ ONLY DISK: D:=RO',0));
        CALL PRINT(@('SET ATTRIBUTE: ',0));
        CALL PRINTX(@FILENAME);
        CALL PRINTX(@ATTRIBUTES);
        CALL PRINT(@('DISK STATUS  : DSK: D:DSK:',0));
        CALL PRINT(@('USER STATUS  : USR: D:USR:',0));
        CALL PRINT(@('IOBYTE ASSIGN:',0));
            DO I = 0 TO 3; /* EACH LINE SHOWS ONE DEVICE */
            CALL CRLF;
            CALL PRNAME(@DEVL(SHL(I,2)));
            CALL PRINTX(@(' =',0));
                DO J = 0 TO 12 BY 4;
                CALL PRINTCHAR(' ');
                CALL PRNAME(@DEVR(SHL(I,4)+J));
                END;
            END;
        CALL CRLF;
        END VALUES; 
 
    ITEMS = 0;
        DO FOREVER;
        IF (I:=MATCH(@DEVL,8)) = 0 THEN DO;
            IF ITEMS<>0 THEN
                GO TO ERROR;
            RETURN FALSE;
            END;
        ITEMS = ITEMS+1; /* FOUND FIRST/NEXT ITEM */
        IF I = 5 THEN /* DEVICE STATUS REQUEST */
            CALL DEVSTATUS;
        ELSE IF I = 6 THEN /* LIST POSSIBLE ASSIGNMENT */
            CALL VALUES;
        ELSE IF I = 7 THEN /* LIST USER STATUS VALUES */
            CALL USERSTATUS;
        ELSE IF I = 8 THEN /* SHOW THE DISK DEVICE STATUS */
            CALL DISKSTATUS; 
        ELSE /* SCAN ITEM I-1 IN DEVICE TABLE */
            DO; /* FIND BASE OF DESTINATION */
            J = SHL(I:=I-1,4);
            IF NOT PARSE$ASSIGN THEN
                GO TO ERROR;
            IF (J:=MATCH(@DEVR(J),4)-1) = 255 THEN
                GO TO ERROR;
            IOBYTE = 1111$1100B; /* CONSTRUCT MASK */
                DO WHILE (I:=I-1) <> 255;
                IOBYTE = ROL(IOBYTE,2);
                J = SHL(J,2);
                END;
            IOVAL = (IOVALF AND IOBYTE) OR J;
            CALL SIOVALF(IOVAL);
            END;
        /* END OF CURRENT ITEM, LOOK FOR MORE */
        IF NOT PARSE$NEXT THEN
            RETURN TRUE;
        END; /* OF DO FOREVER */
ERROR:
    CALL PRINT(@INVALID);
    RETURN TRUE;
    END DEVREQ;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* PRINT THE ACTUAL BYTE COUNT */
PRCOUNT: PROCEDURE(FIXED);
    DECLARE FIXED BYTE;
 
    IF BDOS3 THEN DO;
        CALL SETDMA(@BYTE3);
        CALL GETFREESP(CDISK);
        CALL SHR3BYTE(@BYTE3);
        END;
    ELSE DO;
        BYTE3.HBYTE = 0;
        BYTE3.LWORD = COUNT;
        END;
    CALL P3BYTE(@BYTE3,FIXED);
    CALL PRINTCHAR('K');
    END PRCOUNT;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* PRINT ALLOCATION FOR CURRENT DISK */
PRALLOC: PROCEDURE;
    DCL
         RO ADDRESS;
 
    CALL CRLF;
    CALL SHOW$DRIVE;
    CALL PRINTCHAR('R');
    IF CDISK <> 0 THEN 
        RO = SHR(RODISK,CDISK);
    ELSE
        RO = RODISK;
    IF LOW(RO) THEN
        CALL PRINTCHAR('O'); 
    ELSE
        CALL PRINTCHAR('W');
    CALL PRINTX(@(', FREE SPACE: ',0));
    CALL PRCOUNT(TRUE);
    END PRALLOC;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* PRINT THE STATUS OF THE DISK SYSTEM */
PRSTATUS: PROCEDURE;
    DECLARE LOGIN ADDRESS;
    DECLARE D BYTE;
    LOGIN = GETLOGIN; /* LOGIN VECTOR SET */
    D = 0;
        DO WHILE LOGIN <> 0;
        IF LOW(LOGIN) THEN
            DO; 
            CALL SELECT$DISK(D);
            CALL PRALLOC;
            END;
        LOGIN = SHR(LOGIN,1); 
        D = D + 1;
        END;
    CALL CRLF;
    END PRSTATUS;
 
 
 
 
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 
 
                * * *  DISPLAY FILES  * * *
 
 
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
 
 
                  /* PROCESS FILE DISPLAY OR ATTRIBUTE 
                     ASSIGNMENT */
GETFILE:  PROCEDURE;
    /* PROCESS FILE REQUEST */
 
    DECLARE
        FNAM   LITERALLY '11',   
        FEXT   LITERALLY '12',
        FS1    LITERALLY '13',
        FMOD   LITERALLY '14',
        FRC    LITERALLY '15',   
        FTYP   LITERALLY '9',
        ROFILE LITERALLY '9',   /* READ/ONLY FILE */
        INFILE LITERALLY '10',  /* INVISIBLE FILE */
        ARCHIV LITERALLY '11',  /* ARCHIVED  FILE */
        ATTRB1 LITERALLY  '1',  /* ATTRIBUTE F1'  */
        ATTRB2 LITERALLY  '2',  /* ATTRIBUTE F2'  */
        ATTRB3 LITERALLY  '3',  /* ATTRIBUTE F3'  */
        ATTRB4 LITERALLY  '4';  /* ATTRIBUTE F4'  */
 
    DECLARE
/*68K*/ MEMBASE POINTER,      /* BASE FOR COLLECTING FCBS */
/*68K*/ MEMBASEL LONG AT(@MEMBASE),
        FCBS BASED MEMBASE (1) BYTE,
        FCBN ADDRESS,         /* NUMBER OF FCB'S COLLECTED SO FAR */
        FINX(FCBMAX) ADDRESS, /* INDEX VECTOR USED DURING SORT */
        FCBR(FCBMAX) ADDRESS, /* RECORD COUNT */
/*68K*/ FCBSA POINTER,    /* INDEX INTO FCBS */
/*68K*/ FCBSAL LONG AT(@FCBSA),
/*68K*/ FCBEA POINTER,    /* EXT BYTE OF FCBV */
/*68K*/ FCBEAL LONG AT(@FCBEA),
/*68K*/ FCBS1 POINTER,    /* S1  BYTE OF FCBV */
/*68K*/ FCBS1L LONG AT(@FCBS1),
/*68K*/ FCBMA POINTER,    /* MOD BYTE OF FCBV */
/*68K*/ FCBMAL LONG AT(@FCBMA),
        FCBE BASED FCBEA ADDRESS,     /* EXTENT COUNT IN FCBS ENTRY */
        FCBK BASED FCBMA ADDRESS,     /* KBYTE COUNT IN FCBS ENTRY */
        XFCB BASED FCBS1 BYTE,        /* BIT 7 = XFCB FOR FCBS ENTRY */
        FCBV BASED FCBSA (16) BYTE;   /* TEMPLATE OVER FCBS ENTRY */
        
    DECLARE
        I ADDRESS,     /* FCB COUNTER DURING COLLECTION AND DISPLAY */
        L ADDRESS,     /* USED DURING SORT AND DISPLAY */
        K ADDRESS,     /* " */
        M ADDRESS,     /* " */
        KB BYTE,       /* BYTE COUNTER */
        LB BYTE,       /* BYTE COUNTER */
        MB BYTE,       /* BYTE COUNTER */
        (B,F) BYTE,    /* COUNTERS */
        XFCBFOUND BYTE,/* TRUE MEANS XFCB FOUND */
        WORD$BLKS BYTE, /* 2 BYTE BLOCK ADDRESSES  */
        MATCHED BYTE;  /* USED DURING FCBS SEARCH */
 
    DECLARE
        (SCASE1,SCASE2) BYTE; /* STATUS CASE # */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* DISPLAY A LINE OF B DASHES */
    DOTS: PROCEDURE(I);
        DECLARE I BYTE;
 
        CALL CRLF;
            DO WHILE (I:=I-1) <> -1;
            CALL PRINTCHAR('-');
            END;
        END DOTS;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* PRINT CURRENT FILE NAME */
    PRINTFN: PROCEDURE(A);
        DECLARE
            A POINTER,
            FCBV BASED A (16) BYTE,
            (K, LB) BYTE;
 
        CALL SHOW$DRV;
            DO K = 1 TO FNAM;
            IF K = FTYP THEN 
                CALL PRINTCHAR('.');
            CALL PRINTCHAR(FCBV(K) AND 7FH);
            END;
        END PRINTFN;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* TEST IF ATTRIBUTE FCBV(I) IS ON */
    ATTRIBUTE: PROCEDURE(I) BYTE;
       DECLARE I BYTE;
 
       IF ROL(FCBV(I),1) THEN
          RETURN TRUE;
       RETURN FALSE;
       END ATTRIBUTE;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* PRINT CHARACTER C IF ATTRIBUTE(B) IS TRUE */
    PRNT$ATTRIB: PROCEDURE(B,C);
       DECLARE (B,C) BYTE;
 
       IF ATTRIBUTE(B) THEN
          CALL PRINTCHAR(C);
       ELSE
          CALL PRINTB;
       END PRNT$ATTRIB;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
               /* BUILD AN ALLOCATION VECTOR CHECK FOR DUPPLICATE
                  BLOCKS IN THE DIRECTORY   
                  RETURN TRUE IF NO ERROR, FALSE OTHERWISE  */
    ALLOCATE: PROCEDURE(BLOCK$PTR) BYTE;
        DECLARE 
          BLOCK$PTR POINTER,
          BLOCK$WORD BASED BLOCK$PTR ADDRESS,
          BLOCK$BYTE BASED BLOCK$PTR BYTE,
          (VBYTE, VBIT) WORD,
          AMASK BYTE;
 
        IF WORD$BLKS THEN DO;
            VBYTE = SHR(BLOCK$WORD,11) OR SHL(BLOCK$WORD  AND 0FFH, 5);
            VBIT =  SHR(BLOCK$WORD,8) AND 7;
            END;
        ELSE DO;
            VBYTE = SHR(BLOCK$BYTE,3);
            VBIT = BLOCK$BYTE MOD 8;
            END;
        AMASK = 1000$0000B;
        IF VBIT <> 0 THEN
            AMASK = SHR(1000$0000B,VBIT);
        IF (AMASK AND MEMORY(VBYTE)) = AMASK THEN DO;
            IF FIRST$ERROR THEN DO;
                FIRST$ERROR = FALSE;
                CALL PRINT(@('BAD DIRECTORY ON ',0));
                CALL SHOW$DRV;
                CALL PRINT(@('SPACE ALLOCATION CONFLICT:',0));
                END;
            CALL CRLF;
            CALL SHOW$USR(BFCBUSER);
            CALL BLANKS(8);
            CALL PRINTFN(BFCBA);
            RETURN FALSE;
            END;
        MEMORY(VBYTE) = MEMORY(VBYTE) OR AMASK; 
        RETURN TRUE;
        END ALLOCATE;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* CHECK FOR MATCHING FILE NAMES */
    FILE$MATCH: PROCEDURE(A) BYTE;
       DECLARE 
           I BYTE,
           A POINTER,
           FCB BASED A (16) BYTE;
 
           DO I=1 TO 11;
           IF FCB(I) <> '?' THEN
              IF (FCB(I) AND 7FH) <> (BFCB(I) AND 7FH) THEN
                 RETURN FALSE;
           END;
       RETURN TRUE;
       END FILE$MATCH;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
              /* EXAMINE BLOCK NUMBERS :
                 ALLOC = TRUE  => CHECK FOR DUPLICATE BLOCK NUMBERS
                 ALLOC = FALSE => COUNT KBYTES MAPPED BY FCB  */
    COUNT$BLKS: PROCEDURE(ALLOC);
    DCL (I,ALLOC, NO$ERROR) BYTE;
    NO$ERROR = TRUE;
    I = 32;
        DO WHILE NO$ERROR AND ((I:=I-LB) >= 16);
        MB = BFCB(I);
        IF WORD$BLKS THEN    /* DOUBLE PRECISION INX */
            MB = MB OR BFCB(I+1);
        IF MB <> 0 THEN DO;  /* ALLOCATED */
            IF ALLOC THEN
                NO$ERROR = ALLOCATE(@BFCB(I));
            ELSE
                FCBK = FCBK + KPB;   /* KPB = KBYTES PER BLOCK */
            END;
        END;
    END COUNT$BLKS;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* CHECK NEXT FCB IN SEARCH / SEARCHN */
    CHECK$USER: PROCEDURE;
    DCL I BYTE;
        DO FOREVER;
        IF DCNT = 255 THEN
            RETURN;
   /*   BFCBA = SHL(DCNT,5)+BUFFA;     */
/*68K*/ BFCBA =BUFFA;
/*68K*/ BFCBAL=BFCBAL+LINT(SHL(DCNT,5));
        IF BFCBUSER < 20H THEN DO;
           CALL COUNT$BLKS(TRUE);      /* CHECK FOR DUPLICATE BLOCK */
           IF FILE$MATCH(@FCB) THEN
               IF (BFCBUSER AND 0FH) = USER$CODE 
                   THEN RETURN;        /* PICK UP XFCBS AND FCBS */
           END;
        CALL SEARCHN;
        END;
    END CHECK$USER;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* SET FCBSA TO THE ITH 16 BYTE FCB IN MEMORY 
                     SET FCBEA TO THE EXTENT BYTE OF THAT FCB   */
    MULTI16: PROCEDURE;
        /* UTILITY TO COMPUTE FCBS ADDRESS FROM I */
/*      FCBEA = (FCBSA:=SHL(I,4)+MEMBASE) + FEXT;
        FCBMA = FCBSA + FMOD;
        FCBS1 = FCBSA + FS1;     */
/*68K*/
        FCBSAL=MEMBASEL+LINT(SHL(I,4));
        FCBEAL=FCBSAL+FEXT;
        FCBMAL=FCBSAL+FMOD;
        FCBS1L=FCBSAL+FS1;
/* 68K END */
        END MULTI16;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* PARSE FILE ATTRIBUTE ASSIGNMENT */
    SETFILESTATUS: PROCEDURE BYTE;
            /* EVENTUALLY, SCASE1 & SCASE2
               SET TO R/O=1, R/W=2, DIR=3, SYS=4, SIZE=5 
               SCASE1 IS FIRST ATTRIBUTE ASSIGNMENT 
               SCASE2 IS SECOND ATTRIBUTE ASSIGNMENT */
 
        ERROR: PROCEDURE;
            CALL PRINT(@INVALID);
            CALL PRINT(@USE);
            CALL PRINTX(@FILENAME);
            CALL PRINTX(@('[SIZE] ',0));
            CALL PRINTX(@ATTRIBUTES);
            END ERROR;
 
        IF NOT PARSE$NEXT THEN
            RETURN FALSE;
        IF ACCUM(0) = '=' THEN 
            CALL SCAN;
        IF (SCASE1 := MATCH(@ATTRIBL,5)) = 5 THEN
            RETURN NOT (SIZESET := TRUE);
        /* MUST BE A PARAMETER */
        IF SCASE1 = 0 THEN 
            CALL ERROR;
        ELSE IF PARSE$NEXT THEN 
            IF (SCASE2 := MATCH(@ATTRIBL,5)) = 0 THEN
                CALL ERROR;
        RETURN TRUE;
        END SETFILESTATUS;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* SET THE ATTRIBUTE BITS */
    SET$ATTRIBUTES: PROCEDURE(SCASE);
        DECLARE SCASE BYTE;  
 
        DO CASE SCASE;
        /* SET TO R/O */
            DO;
            FCBV(ROFILE) = FCBV(ROFILE) OR 80H;
            CALL PRINTX(@READONLY);
            END;
        /* SET TO R/W */
            DO;
            FCBV(ROFILE) = FCBV(ROFILE) AND 7FH;
            CALL PRINTX(@READWRITE);
            END;
        /* SET TO SYS */
            DO;
            FCBV(INFILE) = FCBV(INFILE) OR 80H;
            CALL PRINTX(@SYSTEM);
            END;
       /* SET TO DIR */
            DO;
            FCBV(INFILE) = FCBV(INFILE) AND 7FH;
            CALL PRINTX(@DIRECTORY);
            END;
       /* INVALID CASE */
            DO;
            CALL PRINT(@INVALID);
            RETURN;
            END;
       END;
       END SET$ATTRIBUTES;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* CHECK FOR DRIVE STATUS ASSIGNMENT */
    COMPARE$FCB: PROC;
        MATCHED = FALSE; I = 0;
            DO WHILE NOT MATCHED AND I < FCBN;
            /* COMPARE CURRENT ENTRY */
            CALL MULTI16;
            MATCHED = FILE$MATCH(FCBSA);
            I = I + 1;
            END;
        END COMPARE$FCB;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* COPY NEXT FCB INTO FCBS ARRAY */
    COPY$FCB: PROC;
        /* COPY TO NEW POSITION IN FCBS */
        FCBN = (I := FCBN) + 1;
        CALL MULTI16;
        /* FCBSA SET TO NEXT TO FILL */
     /* 68K  MEMSIZE=@DCHAKI;  */
/*68K*/ IF (FCBN > FCBMAX) OR (FCBSAL+ 16) >= MAXBL THEN
            DO; 
            CALL PRINT(@('TOO MANY FILES',0));
            CALL BOOT; /* ABORT */
            END;
        /* SAVE INDEX TO ELEMENT FOR LATER SORT */
        FINX(I) = I;
            DO KB = 0 TO FNAM;
            FCBV(KB) = BFCB(KB);
            END;
        FCBE,FCBK,FCBR(I) = 0;
        END COPY$FCB;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* UPDATE STATISTICS WITH CURRENT FCB BLOCKS */
    ADD$FCB$BLKS: PROC;
        IF BFCB(0) <  10H THEN DO;     
            /* NOT AN XFCB */
 
            /* SET ANY ATTRIBUTE THAT IS ON */
               DO KB=1 TO FNAM;
               IF (BFCB(KB) AND 80H) = 80H THEN
                  FCBV(KB) = FCBV(KB) OR 80H;  /* SET */
               END;
 
            /* RESET ARCHIVED ATTRIBUTE IF IT IS OFF */
            IF (BFCB(ARCHIV) AND 80H) <> 80H THEN
               FCBV(ARCHIV) = FCBV(ARCHIV) AND 7FH; /* RESET */
 
           FCBE = FCBE + 1; /* EXTENT INCREMENTED */
           NFCBS = NFCBS + 1;
 
           /* RECORD COUNT */
           FCBR(I) = FCBR(I) + BFCB(FRC)
                + (BFCB(FEXT) AND DPB$BYTE(EXTMSK$B)) * 128;
           /* COUNT KILOBYTES */
           CALL COUNT$BLKS(FALSE);
           END; 
        ELSE IF BFCB(0) < 20H THEN DO;
           /* XFCB */
           XFCB = XFCB OR 80H;     /* BIT 7 = XFCB EXISTS FLAG */
           NXFCBS = NXFCBS + 1;
           END;
        END ADD$FCB$BLKS;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* SORT THE FILE NAMES IN ASCENDING ORDER */
    SORT: PROCEDURE;
        IF FCBN > 1 THEN /* REQUIRES AT LEAST TWO TO SORT */
            DO; L = 1;
                DO WHILE L > 0; /* BUBBLE SORT */
                CALL TEST$BREAK;
                L = 0;
                    DO M = 0 TO FCBN - 2;
                    I = FINX(M+1); CALL MULTI16; BFCBA = FCBSA; I = FINX(M);
                    CALL MULTI16; /* SETS FCBSA, BASING FCBV */
                        DO KB = 1 TO FNAM; /* COMPARE FOR LESS OR EQUAL */
                        IF (B:=(BFCB(KB) AND 7FH)) 
                            < (F:=(FCBV(KB) AND 7FH)) 
                        THEN /* SWITCH */
                            DO; K = FINX(M); FINX(M) = FINX(M + 1);
                            FINX(M + 1) = K; L = L + 1; KB = FNAM;
                            END;
                        ELSE IF B > F THEN KB = FNAM; /* STOP COMPARE */
                        END;
                    END;
                END;
            END;
        END SORT;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* DISPLAY THE FCBS */
    DISPLAY: PROC;
        DCL (WIDE, ADD, SIZECOLS) BYTE;
 
        ADD, SIZECOLS = 0; 
        IF (WIDE := (COLUMNS > 48)) THEN
            ADD = 7;
        IF SIZESET THEN 
            ADD = ADD + (SIZECOLS := 10);
        CALL PRINT(@DRIVENAME);
        CALL SHOW$DRIVE;
        CALL BLANKS(17+ADD);
        CALL SHOW$USR(USER$CODE);
        IF SIZESET THEN
            CALL PRINT(@('     SIZE ',0));
        ELSE
            CALL CRLF;
        CALL PRINTX(@(' RECS  BYTES FCBS ATTRIB',0));
        IF WIDE THEN 
            CALL PRINTX(@('UTES   ',0));
        CALL PRINTX(@('   NAME',0));
        L = 0;
            DO WHILE L < FCBN;
            I = FINX(L); /* I IS THE INDEX TO NEXT IN ORDER */
            CALL MULTI16; CALL CRLF;            /* SET FCBV,FCBK,FCBE */
            /* PRINT THE FILE LENGTH */
            CALL MOVE(16,@FCBV(0),FCBA);
            FCB(0) = 0;
 
            /* DISPLAY SIZE */
 
            IF SIZESET THEN
                DO; 
                CALL GETFILESIZE(FCBA);
      /* 68K    CALL P3BYTE(RRECA,TRUE);*/ CALL P3BYTEL(RRECA,TRUE);
                CALL PRINTB;
                END;
 
            /* DISPLAY RECORDS */
 
            CALL PDECIMAL(FCBR(I),10000); /* RRRRR */
            CALL PRINTB;
 
            /* DISPLAY KBYTES INCREMENT 1-KBLOCKS (KBLKS) */
 
            KBLKS = (FCBR(I) / 8) + KBLKS;
            IF FCBR(I) MOD 8 <> 0 THEN
                KBLKS = KBLKS + 1;
            CALL PDECIMAL(FCBK,10000);  /* BBBBBK */
            TALL = TALL + FCBK;
            CALL PRINTCHAR('K'); CALL PRINTB;
 
            /* IS THERE AN XFCB ? (CHECK HI-BIT OF S1 BYTE) */
 
            XFCBFOUND = ATTRIBUTE(FS1);        /* SAVE FOR XFCB COLUMN */
            XFCB = XFCB AND 7FH;        /* CLEAR BIT7 */
 
            /* DISPLAY # FCBS */
 
            CALL PDECIMAL(FCBE,1000);   /* EEEE */
 
            CALL PRINTB;
 
            /* DISPLAY ATTRIBUTES: SYS,RO,X,A,F1-F4 */
          
            IF ATTRIBUTE(INFILE) THEN 
                CALL PRINTX(@('SYS',0));
            ELSE
                CALL PRINTX(@('DIR',0));
            CALL PRINTB;
            CALL PRINTCHAR('R');
            IF ATTRIBUTE(ROFILE) THEN
                CALL PRINTCHAR('O'); 
            ELSE
                CALL PRINTCHAR('W');
            CALL PRINTB;
            IF WIDE THEN DO;
                /* DISPLAY # XFCBS (0 OR 1) */
                IF XFCBFOUND THEN 
                   CALL PRINTCHAR('X');
                ELSE
                   CALL PRINTB;
                CALL PRNT$ATTRIB(ARCHIV,'A');
                CALL PRNT$ATTRIB(ATTRB1,'1');
                CALL PRNT$ATTRIB(ATTRB2,'2');
                CALL PRNT$ATTRIB(ATTRB3,'3');
                CALL PRNT$ATTRIB(ATTRB4,'4');
                CALL PRINTB;
                END;
 
            /* DISPLAY FILENAME */
 
            /* PRINT FILENAME.TYP */
            CALL PRINTFN(FCBSA);
 
            /* INCREMENT FCBS COUNTER */
 
            L = L + 1;
            END;
        /* SKIP PAST SIZE AND RECS FIELDS */
        CALL DOTS(39+ADD);
        CALL PRINT(@('TOTAL:',0));
        CALL BLANKS(SIZECOLS);
        CALL PDECIMAL(TALL,10000);    /* TOTAL KBYTES */
        CALL PRINTCHAR('K');
        CALL PDECIMAL(NFCBS,10000);   /* TOTAL # FCBS */
/*        CALL BLANKS(2);
        CALL PRINTCHAR('(');
        CALL PVALUE(FCBN);
        CALL PRINTX(@(' FILE',0));
        IF FCBN < 2 THEN
           CALL PRINTX(@(', ',0));
        ELSE
           CALL PRINTX(@('S, ',0));
        CALL PVALUE(KBLKS);
        CALL PRINTX(@('-1K BLOCKS',0));
        CALL PRINTCHAR(')'); */
        END DISPLAY;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* SET FILE ATTRIBUTES */
    SETFILEATT: PROC;
        L = 0;
            DO WHILE L < FCBN;
            I = L;
            CALL MULTI16;
            CALL CRLF;
            CALL PRINTFN(FCBSA);
            CALL PRINTX(@SET$TO);
            CALL SET$ATTRIBUTES(SCASE1-1);
            IF SCASE2 <> 0 THEN DO;
                CALL PRINTX(@(', ',0));
                CALL SET$ATTRIBUTES(SCASE2-1);
                END;
            FCBV(0) = 0;  /* INCASE MATCHED USER # > 0 */
            CALL SETIND(FCBSA);
            L = L + 1;
            END;
        END SETFILEATT;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* MAIN ROUTINE */
    IF (SET$ATTRIBUTE := SETFILESTATUS) THEN 
        IF SCASE1 = 0 THEN 
            RETURN;
 
    /* READ THE DIRECTORY, COLLECT ALL COMMON FILE NAMES */
    /* SKIP ALLOCATION VECTOR AT THE BASE OF FREE MEMORY
       USED BY THE DUPLICATE BLOCK CHECKING ROUTINES */
 
/* 68K */ I=SHR(DPB$WORD(BLKMAX$W)+7,3) ;
/* 68K */ IF (I MOD 2)=1 THEN I=I+1;
/* 68K */ MEMBASE = @MEMORY;
/* 68K*/  MEMBASEL=MEMBASEL+LINT(I);
    CALL FILL(@MEMORY,0,I);  /* CLEAR ALLOCATION VECTOR */
    LB = 1;
    IF (WORD$BLKS := (DPB$WORD(BLKMAX$W) > 255)) THEN 
        LB = 2;       /* DOUBLE PRECISION BLOCK INDICES */
    FCBN,FCB(0) = 0;
    FCB(FEXT),FCB(FMOD) = '?'; /* QUESTION MARK MATCHES ALL */
    CALL SEARCH(@UFCB); /* FILL DIRECTORY BUFFER */
    CALL CHECK$USER;
 
    /* COLLECT FCBS FOR DISPLAY */
    COLLECT: /* LABEL FOR DEBUG */
 
        DO WHILE DCNT <> 255;
        /* ANOTHER ITEM FOUND, COMPARE IT FOR COMMON ENTRY */
 /*68K  BFCBA = SHL(DCNT AND 11B,5)+BUFFA; /* DCNT MOD 4 * 32 */
 /*68K*/
        DUMMYP=BUFFA;
        DUMMYL=DUMMYL+LINT(SHL(DCNT AND 11B,5));
        BFCBA=DUMMYP;
/* END 68K*/
        CALL COMPARE$FCB;
        IF MATCHED THEN 
            I = I - 1; 
        ELSE
            CALL COPY$FCB;
        /* ENTRY IS AT, OR WAS PLACED AT LOCATION I IN FCBS 
        FCBSA = FINX(I)  */
        CALL ADD$FCB$BLKS;
        CALL SEARCHN; /* TO NEXT ENTRY IN DIRECTORY */
        CALL CHECK$USER;
        END; /* OF DO WHILE DCNT <> 255 */
 
    IF NOT FIRST$ERROR THEN
        CALL BOOT;            /* ABORT IF DUPLICATE BLOCK ERROR */
    IF FCBN = 0 THEN 
        CALL PRINT(@('FILE NOT FOUND',0));
    ELSE IF NOT SET$ATTRIBUTE THEN 
        /* DISPLAY COLLECTED DATA */
        DO;
        CALL SORT;
        CALL DISPLAY;
        CALL PRALLOC;
        END;
    ELSE
        CALL SETFILEATT;
    END GETFILE;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* RESET DRIVE (D:=RW) */
RESET$DRV: PROCEDURE BYTE;
    DCL B ADDRESS;
 
    B = 1;
    IF CDISK <> 0 THEN
        B = SHL(DOUBLE(1),CDISK);
    RETURN MON2(37,B);
    END RESET$DRV;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* CHECK FOR DRIVE STATUS ASSIGNMENT */
SETDRIVESTATUS: PROCEDURE;
    DECLARE I BYTE;
 
    PRDRIVE: PROC(A);
        DCL A POINTER;
        CALL PRINT(@DRIVENAME(1));
        CALL SHOW$DRV;
        CALL PRINTX(@SET$TO);
        CALL PRINTX(A);
        END PRDRIVE;
 
    IF (I := MATCH(@ATTRIBL,2)) = 1 THEN DO;
        CALL WRITEPROT;
        CALL PRDRIVE(@READONLY);
        END;
    ELSE IF I = 2 THEN DO;
        IF RESET$DRV <> 0 THEN
            CALL PRINT(@('DISK RESET DENIED',0));
        ELSE
            CALL PRDRIVE(@READWRITE);
        END;
    ELSE DO;
        CALL PRINT(@INVALID);
        CALL PRINT(@USE);
        CALL PRINTX(@('D:=RO',0));
        END;
    END SETDRIVESTATUS;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 
 
                  /* RESET DRIVE (D:=RW) */
PARSE$IT: PROCEDURE;
    DCL I BYTE;
 
    IF (I:=MATCH(@DEVL,8)) = 8 THEN
        CALL DRIVESTATUS;
    ELSE IF I = 7 THEN
        CALL USERSTATUS;
    ELSE 
        CALL GETFILE;
    END PARSE$IT;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/*        MAIN         */
/*68K*/
/* INIT GLOBAL DATA FOR 68K(BUG OF LINKER)*/
/*                                               */
   SIZESET=0;
   SET$ATTRIBUTE=0;
   IBP=1;
   DO LB=0 TO 6;
      VAL(LB) =0;
      FAC(LB) =0;
   END;
   LB=1;
   FIRST$ERROR=TRUE;
   KBLKS=0;
   NFCBS=0;
   NXFCBS=0;
   TALL=0;
   LAST$DSEG$BYTE=0;
/*      INIT END           */
 
/* 68K */ CALL SETDMA(@BUFF);
 
 /*    VER = VERSION; */ /*SPLH*/
    CDISK = CSELECT;
    USER$CODE = GETUSER;
 /* BDOS3 = (HIGH(VER) = BDOS3VER); */ BDOS3=FALSE; /*SPLH*/
    /* SIZE DISPLAY IF $S SET IN COMMAND */
    IF NOT PARSE$NEXT THEN 
        CALL PRSTATUS;
    ELSE IF ACCUM(1) = ':' THEN DO;
        CALL SELECT$DISK(ACCUM(0)-'A');
        IF NOT PARSE$NEXT THEN 
            CALL PRALLOC;
        ELSE IF ACCUM(0) = '=' THEN
                   CALL PRINT(@('ERROR-READ ONLY STATUS NOT ALLOWED',0));
        ELSE
            CALL PARSE$IT;
        END;
    ELSE DO;
        CALL SET$KPB;
        IF NOT DEVREQ THEN
            CALL GETFILE;
        END;
 
    /* SPLH */ CALL BOOT;
 
    RETURN;
 
    END PLM;
  /* SPLH    MAIN START */
    CALL PLM;
END;
