seppdroid/Digital-Research-Source-Code
1
0
Fork 0
mirror of https://github.com/SEPPDROID/Digital-Research-Source-Code.git synced 2025-10-22 16:04:18 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity
Files
31738079c43b1cd3eae2815a0dfb36f71505257a
Digital-Research-Source-Code/CPM OPERATING SYSTEMS/CPM 2.X/CPM 2.0/stat.plm
Sepp J Morris 31738079c4 Upload 
Digital Research
2020-11-06 18:50:37 +01:00

894 lines
28 KiB
Plaintext
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

stat:
do;
declare
cpmversion literally '20h'; /* requires 2.0 cp/m */
/* c p / m s t a t u s c o m m a n d (s t a t) */
/* 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
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 */
declare jump byte data(0c3h),
jadr address data (.status);
/* jump to status */
/* 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
/* fixed locations for cp/m */
bdosa literally '0006h', /* bdos base */
buffa literally '0080h', /* default buffer */
fcba literally '005ch', /* default file control block */
dolla literally '006dh', /* dollar sign position */
parma literally '006eh', /* parameter, if sent */
rreca literally '007dh', /* random record 7d,7e,7f */
rreco literally '007fh', /* high byte of random overflow */
ioba literally '0003h', /* iobyte address */
sectorlen literally '128', /* sector length */
memsize address at(bdosa), /* 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, /* true if displaying size field */
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;
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;
mon3: procedure(f,a) address external;
declare f byte, a address;
end mon3;
status: procedure;
declare copyright(*) byte data (
' Copyright (c) 1979, Digital Research');
/* dummy outer procedure 'status' will start at 100h */
/* determine status of currently selected disk */
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',
cr literally '13',
lf literally '10';
printchar: procedure(char);
declare char byte;
call mon1(2,char);
end printchar;
crlf: procedure;
call printchar(cr);
call printchar(lf);
end crlf;
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;
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;
break: procedure byte;
return mon2(11,0); /* console ready */
end break;
declare dcnt byte;
version: procedure byte;
/* returns current cp/m version # */
return mon2(12,0);
end 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;
search: procedure(fcb);
declare fcb address;
dcnt = mon2(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 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;
declare oldsp address, /* sp on entry */
stack(16) address; /* this program's stack */
declare
fcbmax literally '512', /* max fcb count */
fcbs literally 'memory',/* remainder of memory */
fcb(33) byte at (fcba), /* default file control block */
buff(128) byte at (buffa), /* default buffer */
ioval byte at (ioba); /* io byte */
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(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;
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;
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;
abortmsg: procedure;
call print(.('** Aborted **',0));
end abortmsg;
userstatus: procedure;
/* display active user numbers */
declare i byte;
declare user(32) byte;
declare ufcb(*) byte data ('????????????',0,0,0);
call print(.('Active User :',0));
call pdecimal(getuser,10);
call print(.('Active Files:',0));
do i = 0 to last(user);
user(i) = false;
end;
call setdma(.fcbs);
call search(.ufcb);
do while dcnt <> 255;
if (i := fcbs(shl(dcnt and 11b,5))) <> 0e5h then
user(i and 1fh) = true;
call searchn;
end;
do i = 0 to last(user);
if user(i) then call pdecimal(i,10);
end;
end userstatus;
drivestatus: procedure;
declare
rpb address,
rpd address;
pv: procedure(v);
declare v address;
call crlf;
call pdecimal(v,10000);
call printchar(':');
call printb;
end pv;
/* print the characteristics of the currently selected drive */
call print(.(' ',0));
call printchar(cselect+'A');
call printchar(':');
call printx(.(' Drive Characteristics',0));
rpb = shl(double(1),blkshf); /* records/block=2**blkshf */
if (rpd := (maxall+1) * rpb) = 0 and (rpb <> 0) then
call print(.('65536: ',0)); else
call pv(rpd);
call printx(.('128 Byte Record Capacity',0));
call pv(count(false));
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/ Extent',0));
call pv(rpb);
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;
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
('CON:RDR:PUN:LST:DEV:VAL:USR:DSK:');
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) 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,8)) = 0 then return items<>0;
items = items+1; /* found first/next item */
if i = 5 then /* device status request */
do;
iobyte = ioval; j = 0;
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; else /* not dev: */
if i = 6 then /* list possible assignment */
do;
call print(.('Temp R/O Disk: d:=R/O',0));
call print(.('Set Indicator: d:filename.typ ',
'$R/O $R/W $SYS $DIR',0));
call print(.('Disk Status : DSK: d:DSK:',0));
call print(.('User Status : 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;
end; else
if i = 7 then /* list user status values */
do; call userstatus;
return true;
end; 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);
call scan;
if accum(0) <> '=' then
do; call print(.('Bad Delimiter',0));
return true;
end;
call scan;
if (j:=match(.devr(j),4)-1) = 255 then
do; call print(.('Invalid Assignment',0));
return true;
end;
iobyte = 1111$1100b; /* construct mask */
do while (i:=i-1) <> 255;
iobyte = rol(iobyte,2);
j = shl(j,2);
end;
ioval = (ioval and iobyte) or j;
end;
/* 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;
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;
call printchar('k');
call crlf;
end pvalue;
comp$alloc: procedure;
alloca = getalloca;
call printchar(cselect+'A');
call printx(.(': ',0));
end comp$alloc;
prcount: procedure;
/* print the actual byte count */
call pvalue(count(true));
end prcount;
pralloc: procedure;
/* print allocation for current disk */
call print (.('Bytes Remaining On ',0));
call comp$alloc;
call prcount;
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 comp$alloc;
call printx(.('R/',0));
if low(rodisk) then
call printchar('O'); else
call printchar('W');
call printx(.(', Space: ',0));
call prcount;
end;
login = shr(login,1); rodisk = shr(rodisk,1);
d = d + 1;
end;
call crlf;
end prstatus;
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',
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 */
declare
fcbn address, /* number of fcb's collected so far */
finx(fcbmax) address, /* index vector used during sort */
fcbe(fcbmax) address, /* extent counts */
fcbb(fcbmax) address, /* byte count (mod kb) */
fcbk(fcbmax) address, /* kilobyte count */
fcbr(fcbmax) address, /* record count */
bfcba address, /* index into directory buffer */
fcbsa address, /* index into fcbs */
bfcb based bfcba (32) byte, /* template over directory */
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 */
matched byte; /* used during fcbs search */
multi16: procedure;
/* utility to compute fcbs address from i */
fcbsa = shl(i,4) + .fcbs;
end multi16;
declare
scase byte; /* status case # */
declare
fstatlist(*) byte data('R/O',0,'R/W',0,'SYS',0,'DIR',0);
setfilestatus: procedure byte;
/* eventually, scase set r/o=0,r/w=1,dat=2,sys=3 */
declare
fstat(*) byte data('R/O R/W SYS DIR ');
if doll = ' ' then return false;
call move(4,.parm,.accum); /* $???? */
if accum(0) = 'S' and accum(1) = ' ' then
return not (sizeset := true);
/* must be a parameter */
if (scase := match(.fstat,4)) = 0 then
call print(.('Invalid File Indicator',0));
return true;
end setfilestatus;
printfn: procedure;
declare (k, lb) byte;
/* print file name */
do k = 1 to fnam;
if (lb := fcbv(k) and 7fh) <> ' ' then
do; if k = ftyp then call printchar('.');
call printchar(lb);
end;
end;
end printfn;
call set$bpb; /* 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(fcba); /* fill directory buffer */
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) <> fcbv(kb) 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));
i = 0; fcbn = 1;
call multi16;
end;
/* save index to element for later sort */
finx(i) = i;
do kb = 0 to fnam;
fcbv(kb) = bfcb(kb);
end;
fcbe(i),fcbb(i),fcbk(i),fcbr(i) = 0;
end;
/* entry is at, or was placed at location i in fcbs */
fcbe(i) = fcbe(i) + 1; /* extent incremented */
/* 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 */
call add$block(.fcbk(i),.fcbb(i));
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)) < (f:=fcbv(kb)) 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;
if sizeset then
call print(.(' Size ',0)); else
call crlf;
call printx(.(' Recs Bytes Ext Acc',0));
l = 0;
do while l < fcbn;
i = finx(l); /* i is the index to next in order */
call multi16; call crlf;
/* print the file length */
call move(16,.fcbv(0),fcba);
fcb(0) = 0;
if sizeset then
do; call getfilesize(fcba);
if rovf <> 0 then call printx(.('65536',0)); else
call pdecimal(rrec,10000);
call printb;
end;
call pdecimal(fcbr(i),10000); /* rrrrr */
call printb; /* blank */
call pdecimal(fcbk(i),10000); /* bbbbbk */
call printchar('k'); call printb;
call pdecimal(fcbe(i),1000); /* eeee */
call printb;
call printchar('R');
call printchar('/');
if rol(fcbv(rofile),1) then
call printchar('O'); else
call printchar('W');
call printb;
call printchar('A'+cselect); call printchar(':');
/* print filename.typ */
if (mb:=rol(fcbv(infile),1)) then call printchar('(');
call printfn;
if mb then call printchar(')');
l = l + 1;
end;
call pralloc;
end; else
setfileatt: /* label for debug */
/* set file attributes */
do;
l = 0;
do while l < fcbn;
if break then
do; call abortmsg; return;
end;
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));
call printx(.fstatlist(shl(scase,2)));
l = l + 1;
end;
end;
end getfile;
setdrivestatus: procedure;
/* 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(.('R/O ')) then
do; call setdisk; /* a: ... */
call writeprot;
end; else
call print(.('Invalid Disk Assignment',0));
end;
else /* not a disk assignment */
do; call setdisk;
if match(.devl,8) = 8 then call drive$status; else
call getfile;
end;
end setdrivestatus;
/* save stack pointer and reset */
oldsp = stackptr;
stackptr = .stack(length(stack));
/* process request */
if version < cpmversion then
call print(.('Wrong CP/M Version (Requires 2.0)',0));
else
do;
/* 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;
/* restore old stack before exit */
stackptr = oldsp;
end status;
end;

Reference in New Issue View Git Blame Copy Permalink