mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-23 08:24:18 +00:00
1386 lines
40 KiB
Plaintext
1386 lines
40 KiB
Plaintext
$ TITLE('MP/M II --- STAT 2.0')
|
||
stat:
|
||
do;
|
||
/* c p / m s t a t u s c o m m a n d (s t a t) */
|
||
|
||
declare
|
||
mpmproduct literally '01h', /* requires mp/m */
|
||
cpmversion literally '30h'; /* requires 3.0 cp/m */
|
||
|
||
/* status status status status status status */
|
||
/* status status status status status status */
|
||
/* status status status status status status */
|
||
/* status status status status status status */
|
||
/* status status status status status status */
|
||
/* status status status status status status */
|
||
/* status status status status status status */
|
||
/* status status status status status status */
|
||
/* status status status status status status */
|
||
/* status status status status status status */
|
||
/* status status status status status status */
|
||
/* status status status status status status */
|
||
/* status status status status status status */
|
||
/* status status status status status status */
|
||
/* status status status status status status */
|
||
/* status status status status status status */
|
||
/* status status status status status status */
|
||
/* status status status status status status */
|
||
/* status status status status status status */
|
||
/* status status status status status status */
|
||
/* status status status status status status */
|
||
/* status status status status status status */
|
||
/* status status status status status status */
|
||
|
||
/*
|
||
copyright(c) 1975, 1976, 1977, 1978, 1979, 1980, 1981
|
||
digital research
|
||
box 579
|
||
pacific grove, ca
|
||
93950
|
||
|
||
Revised:
|
||
20 Jan 80 by Thomas Rolander
|
||
14 Sept 81 by Doug Huskey (for MP/M 2.0)
|
||
*/
|
||
|
||
/* 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 */
|
||
|
||
declare start label;
|
||
declare jump byte data(0c3h),
|
||
jadr address data (.start-3);
|
||
/* jump to status */
|
||
|
||
|
||
declare copyright(*) byte data (
|
||
'Copyright (c) 1981, Digital Research ');
|
||
|
||
/* 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
|
||
*/
|
||
|
||
|
||
|
||
/**************************************
|
||
* *
|
||
* 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;
|
||
|
||
declare cmdrv byte external; /* command drive */
|
||
declare fcb (1) byte external; /* 1st default fcb */
|
||
declare fcb16 (1) 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 (1) byte external; /* default dma buffer */
|
||
|
||
declare
|
||
maxb address external, /* addr field of jmp BDOS */
|
||
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 */
|
||
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 */
|
||
sizeset byte initial(0), /* true if displaying size field */
|
||
user$code byte, /* current user code */
|
||
cdisk byte, /* current disk */
|
||
dpba address, /* disk parameter block address */
|
||
dpb based dpba 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';
|
||
|
||
|
||
boot: procedure external;
|
||
/* reboot */
|
||
end boot;
|
||
|
||
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;
|
||
|
||
|
||
blanks: procedure(b);
|
||
declare b byte;
|
||
do while (b:=b-1) <> -1;
|
||
call printb;
|
||
end;
|
||
end blanks;
|
||
|
||
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 printx(.(cr,lf,'** Aborted **',0));
|
||
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;
|
||
|
||
|
||
version: procedure address;
|
||
/* returns current cp/m version # */
|
||
return mon3(12,0);
|
||
end version;
|
||
|
||
select: procedure(d);
|
||
declare d byte;
|
||
cdisk = d;
|
||
call mon1(14,d);
|
||
end select;
|
||
|
||
open: procedure(fcb);
|
||
declare fcb address;
|
||
dcnt = mon2(15,fcb);
|
||
end open;
|
||
|
||
declare anything byte initial(false);
|
||
declare
|
||
ufcb byte initial('?'), /* search all dir entries */
|
||
bfcba address, /* index into dir buffer */
|
||
bfcbuser based bfcba byte,
|
||
bfcb based bfcba (32) byte; /* template over dirbuff */
|
||
|
||
|
||
check$user: procedure;
|
||
dcl i byte;
|
||
do forever;
|
||
if anything then return;
|
||
if dcnt = 0ffh then return;
|
||
bfcba = shl(dcnt,5)+buffa;
|
||
if bfcbuser >= 20h then
|
||
goto next;
|
||
|
||
do i=1 to 11;
|
||
if fcb(i) <> '?' then
|
||
if fcb(i) <> (bfcb(i) and 7fh) then
|
||
go to next;
|
||
end;
|
||
if (bfcbuser and 0fh) = user$code
|
||
then return; /* pick up xfcbs and fcbs */
|
||
next:
|
||
dcnt = mon2(18,0);
|
||
end;
|
||
end check$user;
|
||
|
||
search: procedure(fcb);
|
||
declare fcb address;
|
||
declare fcb0 based fcb byte;
|
||
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 */
|
||
dpba = mon3(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;
|
||
|
||
declare
|
||
fcbmax literally '512', /* max fcb count */
|
||
spkshf literally '3', /* 2**n sectors per kbyte */
|
||
fcbs literally 'memory',/* remainder of memory */
|
||
ioval byte; /* io byte */
|
||
|
||
declare kpb address; /* kbytes per block */
|
||
|
||
/* 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 set$dpb; /* disk parameters set */
|
||
if (kshf:=blkshf-spkshf) < 1 then
|
||
kpb = 1;
|
||
else
|
||
kpb = shl(double(1),blkshf-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;
|
||
|
||
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;
|
||
|
||
|
||
|
||
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
||
|
||
|
||
* * * SCANNER * * *
|
||
|
||
|
||
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
|
||
|
||
|
||
declare
|
||
accum(4) byte, /* accumulator */
|
||
ibp byte; /* input buffer pointer */
|
||
|
||
declare
|
||
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),
|
||
attributes (*) byte data
|
||
('[ro] [rw] [sys] or [dir]',0);
|
||
|
||
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* compare accumulator with 4 bytes at a */
|
||
compare: procedure(a) byte;
|
||
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;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* get next input value into accum */
|
||
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;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* print a decimal number from 2 byte binary */
|
||
|
||
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;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* 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;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* 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);
|
||
|
||
|
||
|
||
/* 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;
|
||
val(i:=i-1) = 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) 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,fixed);
|
||
declare
|
||
fixed byte,
|
||
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 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 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;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* display current drive */
|
||
show$drive: procedure;
|
||
call printchar(cdisk+'A');
|
||
call printx(.(': ',0));
|
||
end show$drive;
|
||
|
||
|
||
|
||
|
||
|
||
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
||
|
||
|
||
* * * STATUS ROUTINES * * *
|
||
|
||
|
||
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
|
||
|
||
|
||
/* display drive characteristics */
|
||
drivestatus: procedure;
|
||
dcl b3a address,
|
||
b3 based b3a structure (
|
||
lword address,
|
||
hbyte byte);
|
||
|
||
/* print 3 byte value */
|
||
pv3: procedure;
|
||
call crlf;
|
||
call p3byte(buffa,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 = .buff;
|
||
call print(.(' ',0));
|
||
call show$drive;
|
||
call printx(.('Drive Characteristics',0));
|
||
b3.hbyte = 0;
|
||
b3.lword = maxall + 1; /* = # blocks */
|
||
call shl3byte(buffa); /* # blocks * records/block */
|
||
call pv3;
|
||
call printx(.('128 Byte Record Capacity',0));
|
||
call shr3byte(buffa); /* divide by 8 */
|
||
call pv3;
|
||
call printx(.('Kilobyte Drive Capacity',0));
|
||
call pv(dirmax+1);
|
||
call printx(.('32 Byte',0));
|
||
call printx(.entries);
|
||
call pv(shl(chksiz,2));
|
||
call printx(.('Checked',0));
|
||
call printx(.entries);
|
||
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;
|
||
|
||
|
||
userstatus: procedure;
|
||
/* display active user numbers */
|
||
declare i byte;
|
||
declare user(16) byte;
|
||
call crlf;
|
||
call show$drive;
|
||
call printx(.('Active User :',0));
|
||
call pdecimal(getuser,100);
|
||
call crlf;
|
||
call show$drive;
|
||
call printx(.('Active Files:',0));
|
||
do i = 0 to last(user);
|
||
user(i) = false;
|
||
end;
|
||
call setdma(.fcbs);
|
||
anything = true;
|
||
call search(.ufcb);
|
||
do while dcnt <> 255;
|
||
if (i := fcbs(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;
|
||
end userstatus;
|
||
|
||
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;
|
||
|
||
match: procedure(va,vl) byte;
|
||
/* return index+1 to vector at va if match */
|
||
declare va address,
|
||
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;
|
||
|
||
declare devl(*) byte data
|
||
('VAL:USR:DSK:');
|
||
|
||
devreq: procedure byte;
|
||
/* process device request, return true if found */
|
||
/* device tables */
|
||
declare
|
||
(i,j,iobyte,items) byte;
|
||
|
||
|
||
prname: procedure(a);
|
||
declare a address,
|
||
x based a byte;
|
||
/* print device name at a */
|
||
do while x <> ':';
|
||
call printchar(x); a=a+1;
|
||
end;
|
||
call printchar(':');
|
||
end prname;
|
||
|
||
items = 0;
|
||
do forever;
|
||
call scan;
|
||
if (i:=match(.devl,3)) = 0 then return items<>0;
|
||
items = items+1; /* found first/next item */
|
||
if i = 1 then /* list possible assignment */
|
||
do;
|
||
call printx(.('STAT 2.0',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));
|
||
end; else
|
||
if i = 2 then /* list user status values */
|
||
do; call userstatus;
|
||
return true;
|
||
end; else
|
||
if i = 3 then /* show the disk device status */
|
||
call diskstatus;
|
||
/* end of current item, look for more */
|
||
call scan;
|
||
if accum(0) = ' ' then return true;
|
||
if accum(0) <> ',' then
|
||
do; call print(.('Bad Delimiter',0));
|
||
return true;
|
||
end;
|
||
end; /* of do forever */
|
||
end devreq;
|
||
|
||
|
||
/* print the actual byte count */
|
||
prcount: procedure(fixed);
|
||
declare fixed byte;
|
||
|
||
call setdma(.buff);
|
||
call getfreesp(cdisk);
|
||
call shr3byte(.buff);
|
||
call p3byte(.buff,fixed);
|
||
call printchar('k');
|
||
end prcount;
|
||
|
||
pralloc: procedure;
|
||
/* print allocation for current disk */
|
||
call crlf;
|
||
call crlf;
|
||
if sizeset then
|
||
call blanks(17);
|
||
else
|
||
call blanks(7);
|
||
call printx(.('Bytes Remaining On ',0));
|
||
call show$drive;
|
||
call prcount(false);
|
||
call crlf;
|
||
end pralloc;
|
||
|
||
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; call select$disk(d);
|
||
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(true);
|
||
end;
|
||
login = shr(login,1); rodisk = shr(rodisk,1);
|
||
d = d + 1;
|
||
end;
|
||
call crlf;
|
||
end prstatus;
|
||
|
||
|
||
|
||
|
||
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
||
|
||
|
||
* * * DISPLAY FILES * * *
|
||
|
||
|
||
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
|
||
|
||
|
||
DECLARE
|
||
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 */
|
||
|
||
|
||
setdisk: procedure;
|
||
if fcb(0) <> 0 then call select$disk(fcb(0)-1);
|
||
end setdisk;
|
||
|
||
getfile: procedure;
|
||
/* process file request */
|
||
|
||
declare
|
||
fnam literally '11',
|
||
fext literally '12',
|
||
fs1 literally '13',
|
||
fmod literally '14',
|
||
frc literally '15',
|
||
fln literally '15',
|
||
fdm literally '16',
|
||
fdl literally '31',
|
||
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
|
||
fcbn address, /* number of fcb's collected so far */
|
||
finx(fcbmax) address, /* index vector used during sort */
|
||
fcbr(fcbmax) address, /* record count */
|
||
fcbsa address, /* index into fcbs */
|
||
fcbea address, /* ext byte of fcbv */
|
||
fcbs1 address, /* s1 byte of fcbv */
|
||
fcbma address, /* mod byte of fcbv */
|
||
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 */
|
||
matched byte; /* used during fcbs search */
|
||
|
||
/* 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;
|
||
|
||
/* 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;
|
||
|
||
|
||
/* 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)+.fcbs) + fext;
|
||
fcbma = fcbsa + fmod;
|
||
fcbs1 = fcbsa + fs1;
|
||
end multi16;
|
||
|
||
declare
|
||
scase byte; /* status case # */
|
||
|
||
|
||
/* check for R/O or R/W in command buffer for
|
||
compatibility with earilier STATs */
|
||
check$slash: procedure;
|
||
dcl i byte;
|
||
|
||
i=0;
|
||
do while tbuff(i:=i+1) <> 0;
|
||
if tbuff(i)='R' then
|
||
if tbuff(i+1)='/' then
|
||
accum(1) = tbuff(i+2);
|
||
end;
|
||
end check$slash;
|
||
|
||
setfilestatus: procedure byte;
|
||
/* eventually, scase set r/o=0,r/w=1,dat=2,sys=3 */
|
||
declare
|
||
fstat(*) byte data('RO RW SYS DIR ');
|
||
if doll = ' ' then return false;
|
||
if doll = '$' then
|
||
call move(4,.parm+1,.accum); /* $???? */
|
||
else
|
||
call move(4,.parm,.accum); /* [???? */
|
||
if accum(0) = 'S' and accum(1) = 'I' then
|
||
return not (sizeset := true);
|
||
if accum(0) = 'R' then
|
||
call check$slash;
|
||
/* must be a parameter */
|
||
if (scase := match(.fstat,4)) = 0 then do;
|
||
call print(.('Use [size] ',0));
|
||
call printx(.attributes);
|
||
end;
|
||
return true;
|
||
end setfilestatus;
|
||
|
||
printfn: procedure;
|
||
declare (k, lb) byte;
|
||
/* print file name */
|
||
do k = 1 to fnam;
|
||
if k = ftyp then
|
||
call printchar('.');
|
||
call printchar(fcbv(k) and 7fh);
|
||
end;
|
||
end printfn;
|
||
|
||
call set$kpb; /* in case default disk */
|
||
call setdisk;
|
||
sizeset = false;
|
||
scase = 255;
|
||
if setfilestatus then
|
||
do; if scase = 0 then return;
|
||
scase = scase - 1;
|
||
end; else
|
||
if fcb(1) = ' ' then /* no file named */
|
||
do; call pralloc;
|
||
return;
|
||
end;
|
||
|
||
/* read the directory, collect all common file names */
|
||
|
||
fcbn,fcb(0) = 0;
|
||
fcb(fext),fcb(fmod) = '?'; /* question mark matches all */
|
||
call search(.ufcb); /* fill directory buffer */
|
||
|
||
/* collect fcbs for display */
|
||
collect: /* label for debug */
|
||
|
||
do while dcnt <> 255;
|
||
/* another item found, compare it for common entry */
|
||
bfcba = shl(dcnt and 11b,5)+buffa; /* dcnt mod 4 * 32 */
|
||
matched = false; i = 0;
|
||
do while not matched and i < fcbn;
|
||
/* compare current entry */
|
||
call multi16;
|
||
do kb = 1 to fnam;
|
||
if (bfcb(kb) and 7fh) <> (fcbv(kb) and 7fh) then
|
||
kb = fnam;
|
||
else
|
||
/* complete match if at end */
|
||
matched = kb = fnam;
|
||
end;
|
||
i = i + 1;
|
||
end;
|
||
checkmatched: /* label for debug */
|
||
if matched then i = i - 1; else
|
||
do; /* copy to new position in fcbs */
|
||
fcbn = (i := fcbn) + 1;
|
||
call multi16;
|
||
/* fcbsa set to next to fill */
|
||
if (fcbn > fcbmax) or (fcbsa + 16) >= memsize then
|
||
do;
|
||
call print(.('** Too Many Files **',0));
|
||
call mon1(0,0); /* 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;
|
||
|
||
/* entry is at, or was placed at location i in fcbs
|
||
fcbsa = finx(i) */
|
||
|
||
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 extmsk) * 128;
|
||
/* count kilobytes */
|
||
countbytes: /* label for debug */
|
||
lb = 1;
|
||
if maxall > 255 then lb = 2; /* double precision inx */
|
||
do kb = fdm to fdl by lb;
|
||
mb = bfcb(kb);
|
||
if lb = 2 then /* double precision inx */
|
||
mb = mb or bfcb(kb+1);
|
||
if mb <> 0 then /* allocated */
|
||
fcbk = fcbk + kpb; /* kpb = kbytes per block */
|
||
end;
|
||
end;
|
||
else if bfcb(0) < 20h then do;
|
||
/* XFCB */
|
||
xfcb = xfcb or 80h; /* bit 7 = xfcb exists flag */
|
||
nxfcbs = nxfcbs + 1;
|
||
end;
|
||
call searchn; /* to next entry in directory */
|
||
end; /* of do while dcnt <> 255 */
|
||
|
||
display: /* label for debug */
|
||
/* now display the collected data */
|
||
if fcbn = 0 then call print(.('File Not Found',0)); else
|
||
if scase = 255 then /* display collected data */
|
||
do;
|
||
|
||
/* sort the file names in ascending order */
|
||
|
||
if fcbn > 1 then /* requires at least two to sort */
|
||
do; l = 1;
|
||
do while l > 0; /* bubble sort */
|
||
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;
|
||
|
||
/* display */
|
||
|
||
if sizeset then
|
||
call print(.(' Size ',0)); else
|
||
call crlf;
|
||
call printx(.(' Recs Bytes FCBs Attributes 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);
|
||
call p3byte(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 blanks(2);
|
||
|
||
/* 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;
|
||
/* 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;
|
||
|
||
/* display filename */
|
||
|
||
call printchar('A'+cdisk); call printchar(':');
|
||
/* print filename.typ */
|
||
call printfn;
|
||
|
||
/* increment fcbs counter */
|
||
|
||
l = l + 1;
|
||
end;
|
||
|
||
/* print the totals */
|
||
|
||
/* skip past size and recs fields */
|
||
if sizeset then do;
|
||
call dots(57);
|
||
call crlf;
|
||
call blanks(16);
|
||
end;
|
||
else do;
|
||
call dots(47);
|
||
call crlf;
|
||
call blanks(6);
|
||
end;
|
||
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(')');
|
||
call pralloc;
|
||
end; else
|
||
setfileatt: /* label for debug */
|
||
/* set file attributes */
|
||
do;
|
||
l = 0;
|
||
do while l < fcbn;
|
||
i = l;
|
||
call multi16;
|
||
call crlf;
|
||
call printfn;
|
||
do case scase;
|
||
/* set to r/o */
|
||
fcbv(rofile) = fcbv(rofile) or 80h;
|
||
/* set to r/w */
|
||
fcbv(rofile) = fcbv(rofile) and 7fh;
|
||
/* set to sys */
|
||
fcbv(infile) = fcbv(infile) or 80h;
|
||
/* set to dir */
|
||
fcbv(infile) = fcbv(infile) and 7fh;
|
||
end;
|
||
/* place name into default fcb location */
|
||
call move(16,fcbsa,fcba);
|
||
fcb(0) = 0; /* in case matched user# > 0 */
|
||
call setind; /* indicators set */
|
||
call printx(.(' set to ',0));
|
||
do case scase;
|
||
call printx(.readonly);
|
||
call printx(.readwrite);
|
||
call printx(.system);
|
||
call printx(.directory);
|
||
end;
|
||
l = l + 1;
|
||
end;
|
||
end;
|
||
end getfile;
|
||
|
||
setdrivestatus: procedure;
|
||
declare i byte;
|
||
|
||
/* handle possible drive status assignment */
|
||
call scan; /* remove drive name */
|
||
call scan; /* check for = */
|
||
if accum(0) = '=' then
|
||
do; call scan; /* get assignment */
|
||
if compare(.('RO ')) then
|
||
do; call setdisk; /* a: ... */
|
||
call writeprot;
|
||
call crlf;
|
||
call show$drive;
|
||
call printx(.('set to ',0));
|
||
call printx(.readonly);
|
||
end;
|
||
else if compare(.('RW ')) then
|
||
call print(.('Use SET or DSKRESET',0));
|
||
else
|
||
call print(.('Use: STAT d:=RO',0));
|
||
end;
|
||
else /* not a disk assignment */
|
||
do; call setdisk;
|
||
if (i:=match(.devl,3)) = 3 then
|
||
call drivestatus;
|
||
else if i = 2 then
|
||
call userstatus;
|
||
else
|
||
call getfile;
|
||
end;
|
||
end setdrivestatus;
|
||
|
||
declare ver address;
|
||
declare last$dseg$byte byte
|
||
initial (0);
|
||
|
||
start:
|
||
|
||
/* process request */
|
||
|
||
ver = version;
|
||
cdisk = cselect;
|
||
if low(ver) <> cpmversion or high(ver) <> mpmproduct then
|
||
call print (.('Requires MP/M 2.0',0));
|
||
else
|
||
do;
|
||
user$code = getuser;
|
||
/* size display if $S set in command */
|
||
ibp = 1; /* initialize buffer pointer */
|
||
if fcb(0) = 0 and fcb(1) = ' ' then /* stat only */
|
||
call prstatus;
|
||
else
|
||
do;
|
||
if fcb(0) <> 0 then
|
||
call setdrivestatus; else
|
||
do;
|
||
if not devreq then /* must be file name */
|
||
call getfile;
|
||
end;
|
||
end;
|
||
end;
|
||
call mon1 (0,0);
|
||
end;
|
||
|