forked from amberisvibin/chibi-pc09
834 lines
26 KiB
Plaintext
834 lines
26 KiB
Plaintext
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, 1984
|
||
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 03/14/84 to remove iobyte modification for Personal CP/M */
|
||
|
||
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 */
|
||
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) 1984, 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 */
|
||
|
||
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
|
||
('VAL:USR:DSK:');
|
||
|
||
devreq: procedure byte;
|
||
/* process device request, return true if found */
|
||
|
||
declare
|
||
(i,j,items) byte;
|
||
|
||
|
||
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 = 1 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));
|
||
end; else
|
||
if i = 2 then /* list user status values */
|
||
call userstatus;
|
||
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;
|
||
|
||
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) = 3 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 or greater)',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;
|
||
|