seppdroid/Digital-Research-Source-Code
1
0
Fork 0
mirror of https://github.com/SEPPDROID/Digital-Research-Source-Code.git synced 2025-10-24 17:04:19 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity
Files
f5ed2b0a4d18444304007f20e459be89b797c67b
Digital-Research-Source-Code/MPM OPERATING SYSTEMS/MPM-86/MPM-86 2.0 SOURCES/07/SHOW.PLM
Sepp J Morris 31738079c4 Upload 
Digital Research
2020-11-06 18:50:37 +01:00

1435 lines
36 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.

$ 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;

Reference in New Issue View Git Blame Copy Permalink