mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-25 09:24:19 +00:00
1505 lines
38 KiB
Plaintext
1505 lines
38 KiB
Plaintext
$ TITLE('SHOW 2.1: Show Disk Data')
|
|
$ COMPACT
|
|
|
|
|
|
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
|
|
|
|
|
* * * SHOW * * *
|
|
|
|
|
|
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
|
|
|
|
/* Modfification log:
|
|
Oct 82 whf
|
|
Version changes CCPM86 v2.0
|
|
Nov 82 F.Borda
|
|
*/
|
|
|
|
$include (:f2:vaxcmd.lit)
|
|
|
|
|
|
show:
|
|
do;
|
|
declare
|
|
cpmversion literally '20h', /* requires 2.0 cp/m */
|
|
cpm3 literally '30h';
|
|
|
|
|
|
declare copyright(*) byte data
|
|
(' Copyright (c) 1983, Digital Research ');
|
|
|
|
|
|
declare verdate (*) byte data('10/19/82');
|
|
declare version (*) byte data ('SHOW 2.1',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, 1982, 1983
|
|
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 */
|
|
/* modified 06/23/82 by Bill Fitler for CCP/M-86 */
|
|
|
|
|
|
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
|
|
|
|
|
* * * 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;
|
|
declare user(16) byte, /* any files in user i? */
|
|
used(16) address, /* # files in user i */
|
|
nSFCB address, /* # SFCB's */
|
|
free$dir address; /* # free directory entries */
|
|
|
|
|
|
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 * * *
|
|
|
|
|
|
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
|
|
|
|
|
|
get$usr$files: procedure;
|
|
declare ufcb(*) byte data ('????????????',0,0,0),
|
|
(i,j) byte,
|
|
nfcbs address,
|
|
extptr address,
|
|
modptr address,
|
|
fmod based modptr byte,
|
|
fext based extptr byte;
|
|
|
|
do i = 0 to 15;
|
|
user(i),used(i) = 0;
|
|
end;
|
|
nSFCB = 0;
|
|
|
|
call setdma(.dirbuf);
|
|
call search(.ufcb);
|
|
nfcbs = 0;
|
|
|
|
do while dcnt <> 255;
|
|
j = shl(dcnt,5); /* which fcb in dirbuf */
|
|
|
|
ge0: if (i := dirbuf(j)) <> 0e5h then do;
|
|
if i <> 33 then do; /* SFCB ? */
|
|
extptr = .dirbuf(j + 12);
|
|
modptr = extptr + 2;
|
|
nfcbs = nfcbs + 1;
|
|
j = i; /* Save for xfcb test */
|
|
user(i := i and 0fh) = true;
|
|
|
|
if j > 15 then go to ge2;
|
|
if fext > extmsk then go to ge2;
|
|
if fmod = 0 then used(i) = used(i) + 1;
|
|
end;
|
|
else nSFCB = nSFCB + 1;
|
|
end;
|
|
|
|
ge2: call searchn;
|
|
end;
|
|
|
|
if nSFCB > 0 then nSFCB = shr(dirmax+1,2);/* Because search ends
|
|
at high water mark*/
|
|
free$dir = ((dirmax + 1) - nSFCB) - nfcbs;
|
|
|
|
end get$usr$files;
|
|
|
|
|
|
|
|
userstatus: procedure;
|
|
/* display active user numbers */
|
|
declare i byte;
|
|
/*declare user(15) byte;
|
|
declare ufcb(*) byte data ('????????????',0,0,0);*/
|
|
|
|
call set$bpb;
|
|
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));
|
|
call get$usr$files;
|
|
/*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;
|
|
|
|
call crlf;
|
|
call show$drive;
|
|
call printx(.('# of files :',0));
|
|
do i = 0 to last(user);
|
|
if user(i) then call pdecimal(used(i),100,true);
|
|
end;
|
|
|
|
end userstatus;
|
|
|
|
|
|
|
|
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
|
|
|
|
|
* * * MP/M II DISK & FILE STATUS * * *
|
|
|
|
|
|
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
|
|
|
|
|
|
|
|
versionerr: procedure;
|
|
|
|
call print(.('Option not compatible with this O.S.',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 Stamp Stamp',0);
|
|
dcl label2 (*) byte data (
|
|
'Label Reqd ',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)); (Removed with Make XFCB option)
|
|
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;
|