$ TITLE('MP/M-86 2.0 --- SHOW 2.0')
$ COMPACT


/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *


                       * * *  SHOW  * * *


 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */



show:
do;
declare
    cpmversion literally '20h', /* requires 2.0 cp/m */
    cpm3       literally '30h';


declare copyright(*) byte data 
    (' Copyright (c) 1981, Digital Research ');

$include (vaxcmd.lit)

declare verdate (*) byte data('08/04/81');
declare version (*) byte data ('SHOW 2.0',0);



/*      m p / m   s h o w    c o m m a n d      */

/* show    show    show    show    show    show */
/* show    show    show    show    show    show */
/* show    show    show    show    show    show */
/* show    show    show    show    show    show */
/* show    show    show    show    show    show */
/* show    show    show    show    show    show */
/* show    show    show    show    show    show */
/* show    show    show    show    show    show */
/* show    show    show    show    show    show */
/* show    show    show    show    show    show */
/* show    show    show    show    show    show */
/* show    show    show    show    show    show */
/* show    show    show    show    show    show */
/* show    show    show    show    show    show */
/* show    show    show    show    show    show */
/* show    show    show    show    show    show */
/* show    show    show    show    show    show */
/* show    show    show    show    show    show */
/* show    show    show    show    show    show */
/* show    show    show    show    show    show */
/* show    show    show    show    show    show */
/* show    show    show    show    show    show */
/* show    show    show    show    show    show */

/*
            copyright(c) 1975, 1976, 1977, 1978, 1979, 1980, 1981
            digital research
            box 579
            pacific grove, ca
            93950

  */

/* 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 01/20/80 by Thomas Rolander */
/* show created 05/19/81 */
/* show modified for MP/M-86 9/4/81, changes in upper case       */



/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *


                  * * *  MP/M INTERFACE * * *


 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */



/* function call 32 returns the address of the disk parameter
block for the currently selected disk, which consists of:
        scptrk      (2 by) number of sectors per track
        blkshf      (1 by) log2 of blocksize (2**blkshf=blksize)
        blkmsk      (1 by) 2**blkshf-1
        extmsk      (1 by) logical/physical extents
        maxall      (2 by) max alloc number
        dirmax      (2 by) size of directory-1
        dirblk      (2 by) reservation bits for directory
        chksiz      (2 by) size of checksum vector
        offset      (2 by) offset for operating system
*/

declare
    maxb  address external,      /* addr field of jmp BDOS */
    fcb (33) byte external,      /* default file control block */
    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(6eh-5ch)',     /* parameter, if sent */
    rreca literally '.fcb(7dh-5ch)',     /* random record 7d,7e,7f */
    rreco literally '.fcb(7fh-5ch)',     /* high byte of random overflow */
    sectorlen literally '128',   /* sector length */
    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 */
    user$code byte,              /* current user code */
    cversion byte,               /* cpm version # */
    cdisk byte,                  /* current disk  */
    DPBPTR POINTER,              /* disk parameter block address */
    DPB BASED DPBPTR structure
    (spt address, bls byte, bms byte, exm byte, mxa address,
     dmx address, dbl address, cks address, ofs address),
    scptrk literally 'dpb.spt',
    blkshf literally 'dpb.bls',
    blkmsk literally 'dpb.bms',
    extmsk literally 'dpb.exm',
    maxall literally 'dpb.mxa',
    dirmax literally 'dpb.dmx',
    dirblk literally 'dpb.dbl',
    chksiz literally 'dpb.cks',
    offset literally 'dpb.ofs';


mon1: procedure(f,a) external;
    declare f byte, a address;
    end mon1;

mon2: procedure(f,a) byte external;
    declare f byte, a address;
    end mon2;

/* declare mon3 literally 'mon2a'; */

mon3: procedure(f,a) address external;
    declare f byte, a address;
    end mon3;

MON4: PROCEDURE(F,A) POINTER EXTERNAL;
    DECLARE F BYTE, A ADDRESS;
    END MON4;

declare alloca address,
    /* alloca is the address of the disk allocation vector */
    alloc based alloca (1024) byte;  /* allocation vector */

declare
    true literally '1',
    false literally '0',
    forever literally 'while true',
    lit literally 'literally',
    proc literally 'procedure',
    dcl literally 'declare',
    addr literally 'address',
    cr literally '13',
    lf literally '10';

printchar: procedure(char);
    declare char byte;
    call mon1(2,char);
    end printchar;

printb: procedure;
    /* print blank character */
    call printchar(' ');
    end printb;

printx: procedure(a);
    declare a address;
    declare s based a byte;
        do while s <> 0;
        call printchar(s);
        a = a + 1;
        end;
    end printx;

break: procedure byte;
    return mon2(11,0); /* console ready */
    end break;

crlf: procedure;
    call printchar(cr);
    call printchar(lf);
    if break then
    do; call mon1 (1,0);  /* read character */
        call mon1 (0,0);  /* system reset */
    end;
    end crlf;

print: procedure(a);
    declare a address;
    /* print the string starting at address a until the
    next 0 is encountered */
    call crlf;
    call printx(a);
    end print;

declare dcnt byte;

get$version: procedure byte;
    /* returns current cp/m version # */
    return mon2(12,0);
    end get$version;

select: procedure(d);
    declare d byte;
    call mon1(14,d);
    end select;

open: procedure(fcb);
    declare fcb address;
    dcnt = mon2(15,fcb);
    end open;

declare anything byte;
declare dirbuf (128) byte;

check$user: procedure;
    do forever;
        if anything then return;
        if dcnt = 0ffh then return;
        if dirbuf(ror (dcnt,3) and 110$0000b) = user$code
            then return;
        dcnt = mon2(18,0);
    end;
    end check$user;

search: procedure(fcb);
    declare fcb address;
    declare fcb0 based fcb byte;
    anything = (fcb0 = '?');
    dcnt = mon2(17,fcb);
    call check$user;
    end search;

searchn: procedure;
    dcnt = mon2(18,0);
    call check$user;
    end searchn;

cselect: procedure byte;
    /* return current disk number */
    return mon2(25,0);
    end cselect;

setdma: procedure(dma);
    declare dma address;
    call mon1(26,dma);
    end setdma;

getalloca: procedure address;
    /* get base address of alloc vector */
    return mon3(27,0);
    end getalloca;

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;

getrodisk: procedure address;
    /* get the read-only disk vector */
    return mon3(29,0);
    end getrodisk;

setind: procedure;
    /* set file indicators for current fcb */
    call mon1(30,fcba);
    end setind;

set$dpb: procedure;
    /* set disk parameter block values */
    DPBPTR = MON4(31,0);    /* base of dpb */
    end set$dpb;

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 address;
    call mon1(35,fcb);
    end getfilesize;

getfreesp: procedure(d);
    declare d byte;

    call mon1(46,d);
    end getfreesp;

getlbl: procedure(d) byte;
    declare d byte;

    return mon2(101,d);
    end getlbl;

  declare
    parse$fn structure (
      buff$adr  address,
      fcb$adr   address),
    delimiter based parse$fn.buff$adr byte;

  parse: procedure address;
    return mon3(152,.parse$fn);
    end parse;

terminate: procedure;
    call mon1 (0,0);				/* system reset */
    end terminate;


/*****************************************************

          Time & Date ASCII Conversion Code

 *****************************************************/

declare tod$adr address;
declare tod based tod$adr structure (
  opcode byte,
  date address,
  hrs byte,
  min byte,
  sec byte,
  ASCII (21) byte );

declare string$adr address;
declare string based string$adr (1) byte;
declare index byte;

emitchar: procedure(c);
    declare c byte;
    string(index := index + 1) = c;
    end emitchar;

emitn: procedure(a);
    declare a address;
    declare c based a byte;
    do while c <> '$';
      string(index := index + 1) = c;
      a = a + 1;
    end;
    end emitn;


emit$bcd: procedure(b);
    declare b byte;
    call emitchar('0'+b);
    end emit$bcd;

emit$bcd$pair: procedure(b);
    declare b byte;
    call emit$bcd(shr(b,4));
    call emit$bcd(b and 0fh);
    end emit$bcd$pair;

emit$colon: procedure(b);
    declare b byte;
    call emit$bcd$pair(b);
    call emitchar(':');
    end emit$colon;

emit$bin$pair: procedure(b);
    declare b byte;
    call emit$bcd(b/10);	/* makes garbage if not < 10 */
    call emit$bcd(b mod 10);
    end emit$bin$pair;

emit$slant: procedure(b);
    declare b byte;
    call emit$bin$pair(b);
    call emitchar('/');
    end emit$slant;

declare chr byte;

gnc: procedure;
    /* get next command byte */
    if chr = 0 then return;
    if index = 20 then
    do;
      chr = 0;
      return;
    end;
    chr = string(index := index + 1);
    end gnc;

deblank: procedure;
        do while chr = ' ';
        call gnc;
        end;
    end deblank;

numeric: procedure byte;
    /* test for numeric */
    return (chr - '0') < 10;
    end numeric;

scan$numeric: procedure(lb,ub) byte;
    declare (lb,ub) byte;
    declare b byte;
    b = 0;
    call deblank;
    if not numeric then call terminate;
        do while numeric;
        if (b and 1110$0000b) <> 0 then call terminate;
        b = shl(b,3) + shl(b,1); /* b = b * 10 */
        if carry then call terminate;
        b = b + (chr - '0');
        if carry then call terminate;
        call gnc;
        end;
    if (b < lb) or (b > ub) then call terminate;
    return b;
    end scan$numeric;

scan$delimiter: procedure(d,lb,ub) byte;
    declare (d,lb,ub) byte;
    call deblank;
    if chr <> d then call terminate;
    call gnc;
    return scan$numeric(lb,ub);
    end scan$delimiter;

declare
    base$year lit '78',   /* base year for computations */
    base$day  lit '0',    /* starting day for base$year 0..6 */
    month$size (*) byte data
    /* jan feb mar apr may jun jul aug sep oct nov dec */
    (   31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31),
    month$days (*) address data
    /* jan feb mar apr may jun jul aug sep oct nov dec */
    (  000,031,059,090,120,151,181,212,243,273,304,334);

leap$days: procedure(y,m) byte;
    declare (y,m) byte;
    /* compute days accumulated by leap years */
    declare yp byte;
    yp = shr(y,2); /* yp = y/4 */
    if (y and 11b) = 0 and month$days(m) < 59 then
        /* y not 00, y mod 4 = 0, before march, so not leap yr */
        return yp - 1;
    /* otherwise, yp is the number of accumulated leap days */
    return yp;
    end leap$days;

declare word$value address;

get$next$digit: procedure byte;
    /* get next lsd from word$value */
    declare lsd byte;
    lsd = word$value mod 10;
    word$value = word$value / 10;
    return lsd;
    end get$next$digit;

bcd:
  procedure (val) byte;
    declare val byte;
    return shl((val/10),4) + val mod 10;
  end bcd;

declare (month, day, year, hrs, min, sec) byte;

 set$date$time: procedure;
    declare
        (i, leap$flag) byte; /* temporaries */
    month = scan$numeric(1,12) - 1;
    /* may be feb 29 */
    if (leap$flag := month = 1) then i = 29;
        else i = month$size(month);
    day   = scan$delimiter('/',1,i);
    year  = scan$delimiter('/',base$year,99);
    /* ensure that feb 29 is in a leap year */
    if leap$flag and day = 29 and (year and 11b) <> 0 then
        /* feb 29 of non-leap year */ call terminate;
    /* compute total days */
    tod.date = month$days(month)
                + 365 * (year - base$year)
                + day
                - leap$days(base$year,0)
                + leap$days(year,month);

    tod.hrs   = bcd (scan$numeric(0,23));
    tod.min   = bcd (scan$delimiter(':',0,59));
    if tod.opcode = 2 then
    /* date, hours and minutes only */
    do;
      if chr = ':'
        then i = scan$delimiter (':',0,59);
      tod.sec = 0;
    end;
    /* include seconds */
    else tod.sec   = bcd (scan$delimiter(':',0,59));

    end set$date$time;

bcd$pair: procedure(a,b) byte;
    declare (a,b) byte;
    return shl(a,4) or b;
    end bcd$pair;


compute$year: procedure;
    /* compute year from number of days in word$value */
    declare year$length address;
    year = base$year;
        do forever;
        year$length = 365;
        if (year and 11b) = 0 then /* leap year */
            year$length = 366;
        if word$value <= year$length then
            return;
        word$value = word$value - year$length;
        year = year + 1;
        end;
    end compute$year;

declare
    week$day  byte, /* day of week 0 ... 6 */
    day$list (*) byte data
    ('Sun$Mon$Tue$Wed$Thu$Fri$Sat$'),
    leap$bias byte; /* bias for feb 29 */

compute$month: procedure;
    month = 12;
        do while month > 0;
        if (month := month - 1) < 2 then /* jan or feb */
            leapbias = 0;
        if month$days(month) + leap$bias < word$value then return;
        end;
    end compute$month;

declare
    date$test byte,    /* true if testing date */
    test$value address;   /* sequential date value under test */

get$date$time: procedure;
    /* get date and time */
    hrs = tod.hrs;
    min = tod.min;
    sec = tod.sec;
    word$value = tod.date;
    /* word$value contains total number of days */
    week$day = (word$value + base$day - 1) mod 7;
    call compute$year;
    /* year has been set, word$value is remainder */
    leap$bias = 0;
    if (year and 11b) = 0 and word$value > 59 then
        /* after feb 29 on leap year */ leap$bias = 1;
    call compute$month;
    day = word$value - (month$days(month) + leap$bias);
    month = month + 1;
    end get$date$time;

emit$date$time: procedure;
    if tod.opcode = 0 then
      do;
      call emitn(.day$list(shl(week$day,2)));
      call emitchar(' ');
      end;
    call emit$slant(month);
    call emit$slant(day);
    call emit$bin$pair(year);
    call emitchar(' ');
    call emit$colon(hrs);
    call emit$colon(min);
    if tod.opcode = 0 then
      call emit$bcd$pair(sec);
    end emit$date$time;

tod$ASCII:
  procedure (parameter);
    declare parameter address;
    declare ret address;

    ret = 0;
    tod$adr = parameter;
    string$adr = .tod.ASCII;
    if	(tod.opcode = 0) or
	(tod.opcode = 3) then
    do;
      call get$date$time;
      index = -1;
      call emit$date$time;
    end;
    else
    do;
      if (tod.opcode = 1) or
         (tod.opcode = 2) then
      do;
        chr = string(index:=0);
        call set$date$time;
        ret = .string(index);
      end;
      else
      do;
        call terminate;
      end;
    end;
  end tod$ASCII;

/********************************************************


                  TOD INTERFACE TO SHOW


 ********************************************************/


  declare lcltod structure (
    opcode byte,
    date address,
    hrs byte,
    min byte,
    sec byte,
    ASCII (21) byte );

  declare datapgadr address;
  declare datapg based datapgadr address;

  declare extrnl$todadr address;
  declare extrnl$tod based extrnl$todadr structure (
    date address,
    hrs byte,
    min byte,
    sec byte );

  declare ret address;

/*  display$tod:
    procedure;
      lcltod.opcode = 0; 
      call move (5,.extrnl$tod.date,.lcltod.date);
      call tod$ASCII (.lcltod);
      call write$console (0dh);
      do i = 0 to 20;
        call write$console (lcltod.ASCII(i));
      end;
    end display$tod; */

  display$ts:
     procedure (tsadr);
     dcl i byte;
     dcl tsadr address;
     lcltod.opcode = 3;		/* display time and date stamp, no seconds */
     call move (4,tsadr,.lcltod.date);	/* don't copy seconds */
     call tod$ASCII (.lcltod);
     do i = 0 to 13;
       call printchar (lcltod.ASCII(i));
     end;	
  end display$ts;

/******** End TOD Code ********/




/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *


                       * * *  BASIC ROUTINES * * *


 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */


declare
    fcbmax literally '512'; /* max fcb count */

declare bpb address; /* bytes per block */

set$bpb: procedure;
    call set$dpb; /* disk parameters set */
    bpb = shl(double(1),blkshf) * sectorlen;
    end set$bpb;

select$disk: procedure(d);
    declare d byte;
    /* select disk and set bpb */
    call select(cdisk:=d);
    call set$bpb; /* bytes per block */
    end select$disk;

getalloc: procedure(i) byte;
    /* return the ith bit of the alloc vector */
    declare i address;
    return
    rol(alloc(shr(i,3)), (i and 111b) + 1);
    end getalloc;

declare
    accum(4) byte,    /* accumulator */
    ibp byte;         /* input buffer pointer */

compare: procedure(a) byte;
    /* compare accumulator with four bytes addressed by a */
    declare a address;
    declare (s based a) (4) byte;
    declare i byte;
        do i = 0 to 3;
        if s(i) <> accum(i) then return false;
        end;
    return true;
    end compare;

scan: procedure;
    /* fill accum with next input value */
    declare (i,b) byte;
    setacc: procedure(b);
        declare b byte;
        accum(i) = b; i = i + 1;
        end setacc;
    /* deblank input */
        do while buff(ibp) = ' '; ibp=ibp+1;
        end;
    /* initialize accum length */
    i = 0;
        do while i < 4;
        if (b := buff(ibp)) > 1 then /* valid */
            call setacc(b); else /* blank fill */
            call setacc(' ');
        if b <= 1 or b = ',' or b = ':' or
          b = '*' or b = '.' or b = '>' or
          b = '<' or b = '=' then buff(ibp) = 1;
        else
            ibp = ibp + 1;
        end;
    ibp = ibp + 1;
    end scan;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */


                  /* fill string @ s for c bytes with f */
fill:   proc(s,f,c);
    dcl s addr,
        (f,c) byte,
        a based s byte;

        do while (c:=c-1)<>255;
        a = f;
        s = s+1;
        end;
    end fill;


/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *


                   * * *  PRINT A 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 */
    f0  (7) byte initial(6,3,5,5,6,0,0),   /*    65,536     */
    f1  (7) byte initial(2,7,0,1,3,1,0),   /*   131,072     */
    f2  (7) byte initial(4,4,1,2,6,2,0),   /*   262,144     */
    f3  (7) byte initial(8,8,2,4,2,5,0),   /*   524,288     */
    f4  (7) byte initial(6,7,5,8,4,0,1),   /* 1,048,576     */
    f5  (7) byte initial(2,5,1,7,9,0,2),   /* 2,097,152     */
    f6  (7) byte initial(4,0,3,4,9,1,4),   /* 4,194,304     */
    ptr (7) address initial(.f0,.f1,.f2,.f3,.f4,.f5,.f6);



                  /* print decimal value of address v */
pdecimal: procedure(v,prec,zerosup);
    /* print value v with precision prec (1,10,100,1000,10000)
    with leading zero suppression if zerosup = true */
    declare
        v address,    /* value to print */
        prec address, /* precision */
        zerosup byte, /* zero suppression flag */
        d byte;       /* current decimal digit */
          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;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */


                  /* BCD - convert 16 bit binary to 
                     7 one byte BCD digits */
getbcd: procedure(value);
    declare
        (value,prec) address,
        i byte;

    prec = 10000;
    i = 5;                            /* digits: 4,3,2,1,0 */
        do while prec <> 0;
        val(i:=i-1) = value / prec;   /* get next digit */
        value = value mod prec;       /* remainder in value */
        prec = prec / 10;
        end;
    end getbcd;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */


                  /* print BCD number in val array */
printbcd: procedure;
   declare 
       (zerosup, i) byte;

   pchar: procedure(c);
       declare c byte;
       if val(i) = 0 then
           if zerosup then 
               if i <> 0 then do;
                   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)        address,
        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;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */


                  /* print 3 byte value based at byte3adr */
p3byte: procedure(byte3adr);
   declare
      i         byte,  
      high$byte byte,
      byte3adr  address,
      b3 based  byte3adr structure (
          lword address,
          hbyte byte);

    call fill(.val,0,7);
    call fill(.fac,0,7);
    call getbcd(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;                    /* print value */
    end p3byte;


	/* divide 3 byte value by 8 */
shr3byte: procedure(byte3adr);
      dcl byte3adr address,
          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 */
	end shr3byte;


	/* multiply 3 byte value by #records per block */
shl3byte: procedure(byte3adr);
      dcl byte3adr address,
          b3 based byte3adr structure (
	  lword address,
          hbyte byte),
	  temp1 based byte3adr (2) byte;

	b3.hbyte = (rol(temp1(1),blkshf) and blkmsk) or shl(b3.hbyte,blkshf);
	b3.lword = shl(b3.lword,blkshf);
	end shl3byte;


show$drive: procedure;
    call printchar(cdisk+'A');
    call printx(.(': ',0));
    end show$drive;




/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *


                * * *  CALCULATE SIZE  * * *


 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */


add$block: procedure(ak,ab);
    declare (ak, ab) address;
    /* add one block to the kilobyte accumulator */
    declare kaccum based ak address; /* kilobyte accum */
    declare baccum based ab address; /* byte accum */
    baccum = baccum + bpb;
        do while baccum >= 1024;
        baccum = baccum - 1024;
        kaccum = kaccum + 1;
        end;
    end add$block;

count: procedure(mode) address;
    declare mode byte; /* true if counting 0's */
    /* count kb remaining, kaccum set upon exit */
    declare
        ka  address,  /* kb accumulator */
        ba  address,  /* byte accumulator */
        i   address,  /* local index */
        bit byte;     /* always 1 if mode = false */
    ka, ba = 0;
    bit = 0;
        do i = 0 to maxall;
        if mode then bit = getalloc(i);
        if not bit then call add$block(.ka,.ba);
        end;
    return ka;
    end count;




/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *


                 * * *  STATUS ROUTINES  * * *


 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */



                  /* characteristics of current drive */
drivestatus: procedure;
      dcl b3a address,
          b3 based b3a structure (
             lword address,
             hbyte byte);

         /* print 3 byte value */
    pv3: procedure;
         call crlf;
         call p3byte(.dirbuf);
         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 = .dirbuf;
    call print(.('        ',0));
    call show$drive;
    call printx(.('Drive Characteristics',0));
    b3.hbyte = 0;
    b3.lword = maxall + 1;       /* = # blocks */
    call shl3byte(.dirbuf);        /* # blocks * records/block */
    call pv3;
    call printx(.('128 Byte Record Capacity',0));
    call shr3byte(.dirbuf);        /* divide by 8 */
    call pv3;
    call printx(.('Kilobyte Drive  Capacity',0));
    call pv(dirmax+1);
    call printx(.('32 Byte  Directory Entries',0));
    call pv(shl(chksiz,2));
    call printx(.('Checked  Directory Entries',0));
    call pv((extmsk+1) * 128);
    call printx(.('Records / Directory Entry',0));
    call pv(shl(double(1),blkshf));
    call printx(.('Records / Block',0));
    call pv(scptrk);
    call printx(.('Sectors / Track',0));
    call pv(offset);
    call printx(.('Reserved  Tracks',0));
    call crlf;
    end drivestatus;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */


                  /* characteristics of all logged in disks */
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;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */


                  /* help message */
help: procedure;
    /* display possible commands */

    call print(.('Drive Status    : SHOW DRIVE:  SHOW d:DRIVE:',0));
    call print(.('User Status     : SHOW USERS:  SHOW d:USERS:',0));
    call print(.('Directory Label : SHOW LABEL:  SHOW d:LABEL:',0));
    call print(.('Free Disk Space : SHOW SPACE:  SHOW d:SPACE:',0));
/*
    call print(.('Locked Records  : LOCKED:',0));
    call print(.('Open Files      : OPEN:',0)); 
*/
    call crlf;
    end help;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */


                  /* parse error message */
parse$error: procedure;

    call print(.version);
    call crlf;
    call print(.('Invalid Option, use the following:',0));
    call crlf;
    call help;
    call terminate;
    end parse$error;




/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *


                       * * *  DISK STATUS  * * *


 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */


pvalue: procedure(v);
    declare (d,zero) byte,
        (k,v) address;
    k = 10000;
    zero = false;
        do while k <> 0;
        d = low(v/k); v = v mod k;
        k = k / 10;
        if zero or k = 0 or d <> 0 then
             do; zero = true; call printchar('0'+d);
             end;
        end;
    end pvalue;


prcount: procedure;

    /* print the actual byte count */
    if cversion < cpm3 then do;
        alloca = getalloca;
	call pvalue(count(true));
        end;
    else do;
	call setdma(.dirbuf);
	call getfreesp(cdisk);
	call shr3byte(.dirbuf);
	call p3byte(.dirbuf);
	end; 
    call printchar('k');
    end prcount;

stat: procedure(rodisk);
	declare rodisk address;

	call crlf;
        call show$drive;
        call printchar('R');
        if low(rodisk) then
            call printchar('O'); else
            call printchar('W');
        call printx(.(', Space: ',0));
        call prcount;
	end stat;

prstatus: procedure;
    /* print the status of the disk system */
    declare (login, rodisk) address;
    declare d byte;

    login = getlogin; /* login vector set */
    rodisk = getrodisk; /* read only disk vector set */
    d = 0;
        do while login <> 0;
        if low(login) then
            do; 
	    if fcb(0) <> 0 then do;
		if fcb(0)-1 = d then
	            call stat(rodisk);		/* do specific disk */
	        end;
	    else do;
                call select$disk(d);
	        call stat(rodisk);		/* do all disks */
	        end;
            end;
        login = shr(login,1); rodisk = shr(rodisk,1);
        d = d + 1;
        end;
    end prstatus;




/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *


                * * *  USER STATUS * * *


 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */



userstatus: procedure;
    /* display active user numbers */
    declare i byte;
    declare user(15) byte;
    declare ufcb(*) byte data ('????????????',0,0,0);

    call crlf;
    call show$drive;
    call printx(.('Active User :',0));
    call pdecimal(getuser,100,true);
    call crlf;
    call show$drive;
    call printx(.('Active Files:',0));
        do i = 0 to last(user);
        user(i) = false;
        end;
    call setdma(.dirbuf);
    call search(.ufcb);
        do while dcnt <> 255;
        if (i := dirbuf(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,true);
        end;
    end userstatus;



/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *


            * * *  MP/M II DISK & FILE STATUS * * *


 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */



versionerr: procedure;

    call print(.('Requires MP/M 2.0',0));
    call terminate;
    end versionerr;

openfiles: procedure;

    if cversion < cpm3 then
	call versionerr;
    call print(.('Not yet implemented',0));
    end openfiles;

lockedstatus: procedure;

    if cversion < cpm3 then
	call versionerr;
    call print(.('Not yet implemented',0));
    end lockedstatus;

/*******************************************************

		L A B E L   S T A T U S

********************************************************/

readlbl: proc;
    dcl d byte data('?');
    
    call setdma(.dirbuf);
    call search(.d);
	do while dcnt <> 0ffH;
	if dirbuf(ror(dcnt,3) and 110$0000b)=20H then
	    return;
	call searchn;
	end;
    end readlbl;

/* HEADER */

dcl label1 (*) byte data (
'Directory     Passwds  Make   Stamp   Stamp',0);
dcl label2 (*) byte data (
'Label         Reqd     XFCBs  ',0);
dcl label3 (*) byte data (
                                    '  Update  Label Created   Label Updated',0);
dcl label4 (*) byte data (
'------------  -------  -----  ------  ------  --------------  --------------',0);


labelstatus: procedure;
    dcl (lbl, make)  byte;
    dcl fnam lit '11';
    dcl ftyp lit '9';
    dcl fcbp address;
    dcl fcbv based fcbp (32) byte;	/* template over dirbuf */
	
    /* print file name */
    printfn: proc;
    declare k byte;

 	do k = 1 to fnam;
	if k = ftyp then 
	    call printchar('.');
	call printchar(fcbv(k) and 7fh);
	end;
    end printfn;

    if cversion < cpm3 then
	call versionerr;
    lbl = getlbl(cdisk);
    if lbl > 0 then do;
	call readlbl;
	fcbp = shl(dcnt,5) + .dirbuf;

	/* print heading */
	call print(.('Label for drive ',0));
	call show$drive;
	call crlf;
	call print(.label1);
	call print(.label2);
	if (lbl and 40h) = 40h then
	    call printx(.('Access',0));
	else
	    call printx(.('Create',0));
	call printx(.label3);
	call print(.label4);
	call crlf;
	call printfn;
	if (lbl and 80h) = 80h then
	    call printx(.('    on   ',0));
	else
	    call printx(.('    off  ',0));
	
	if (make:=(lbl and 10h) = 10h) then
	    call printx(.('   on  ',0));
	else
	    call printx(.('   off ',0));
	if ((lbl and 40h) = 40h) or make then
	    call printx(.('   on   ',0));
	else
	    call printx(.('   off  ',0));
	if (lbl and 20h) = 20h then
	    call printx(.('   on ',0));
	else
	    call printx(.('   off',0));

	call printx(.('    ',0));
	call display$ts(.fcbv(24));
	call printx(.('  ',0));
	call display$ts(.fcbv(28));
	end;
    else
	call print(.('No Directory Label exists',0));
    call crlf;
    end labelstatus;


/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *


                    * * *  PARSING  * * *


 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */



parse$next: procedure;

    /* skip comma or space delimiter */
    parse$fn.buff$adr = parse$fn.buff$adr + 1;
    parse$fn.buff$adr = parse;
    if parse$fn.buff$adr = 0ffffh then 
        call parse$error;
    if delimiter = ']' or delimiter = ':' then     /* skip */
        parse$fn.buff$adr = parse$fn.buff$adr + 1;
    if delimiter = 0 then
        parse$fn.buff$adr = 0;
    end parse$next;


/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *


                  * * *  MAIN PROGRAM  * * *


 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

declare 
    i              byte initial(1),
    last$dseg$byte byte initial (0);


PLMSTART: PROCEDURE PUBLIC;

/* process request */
cversion = get$version;
ibp=1;
if cversion < cpmversion then
    call printx(.('Requires CP/M 2.0',0));
    else
        do;
            /* scan for global option */
            do while buff(i)=' ';
            i = i + 1;
            end;
        if buff(i) = '[' then    /* skip leading [ */
            parse$fn.buff$adr = .buff(i);
        else
            parse$fn.buff$adr = .buff;
        parse$fn.fcb$adr = .fcb;
	cdisk = cselect;
        user$code = getuser;
            do while parse$fn.buff$adr <> 0;
            call parse$next;
            if fcb(0) <> 0 then         /* get drive  */
            	call select$disk(fcb(0)-1);
            if delimiter = '[' then
                call parse$next;        /* get option */
            if fcb(1) = ' ' or fcb(1) = 'S' then
            	call prstatus;
            else if fcb(1) = 'U' then
            	call userstatus;
            else if fcb(1) = 'H' then
            	call help;
            else if fcb(1) = 'D' then
            	do;
            	if fcb(0)<>0 then
            		call drivestatus;
            	else
            		call diskstatus;
            	end;
            else if fcb(1) = 'O' then
            	call openfiles;
            else if fcb(1) = 'L' then do;
            	if fcb(2) = 'A' then 
            		call labelstatus;
            	else if fcb(2) = 'O' then
            		call lockedstatus;
            	else
            		call parse$error;
            	end;
            else
            	call parse$error;
            end;
        end;
    call terminate;
END PLMSTART;
end show;
