mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-26 01:44:21 +00:00
1 line
12 KiB
Plaintext
1 line
12 KiB
Plaintext
$title('MP/M 1.1 Status Process')
|
||
status:
|
||
do;
|
||
|
||
$include (copyrt.lit)
|
||
/*
|
||
Revised:
|
||
19 Jan 80 by Thomas Rolander
|
||
*/
|
||
|
||
declare start label;
|
||
declare jmp$to$start structure (
|
||
jmp$instr byte,
|
||
jmp$location address ) data (
|
||
0C3H,.start-3);
|
||
|
||
$include (dpgos.lit)
|
||
$include (proces.lit)
|
||
$include (queue.lit)
|
||
$include (memmgr.lit)
|
||
$include (xdos.lit)
|
||
|
||
|
||
/*
|
||
Common Literals
|
||
*/
|
||
|
||
declare true literally '0FFFFH';
|
||
declare false literally '0';
|
||
declare forever literally 'while true';
|
||
declare boolean literally 'byte';
|
||
|
||
mon1:
|
||
procedure (func,info) external;
|
||
declare func byte;
|
||
declare info address;
|
||
end mon1;
|
||
|
||
mon2:
|
||
procedure (func,info) byte external;
|
||
declare func byte;
|
||
declare info address;
|
||
end mon2;
|
||
|
||
mon2a:
|
||
procedure (func,info) address external;
|
||
declare func byte;
|
||
declare info address;
|
||
end mon2a;
|
||
|
||
co:
|
||
procedure (char);
|
||
declare char byte;
|
||
call mon1 (2,char);
|
||
end co;
|
||
|
||
print$buffer:
|
||
procedure (bufferadr);
|
||
declare bufferadr address;
|
||
call mon1 (9,bufferadr);
|
||
end print$buffer;
|
||
|
||
read$buffer:
|
||
procedure (bufferadr);
|
||
declare bufferadr address;
|
||
call mon1 (10,bufferadr);
|
||
end read$buffer;
|
||
|
||
crlf:
|
||
procedure;
|
||
call co (0DH);
|
||
call co (0AH);
|
||
end crlf;
|
||
|
||
declare xdos literally 'mon2a';
|
||
|
||
declare datapgadr address;
|
||
declare datapg based datapgadr address;
|
||
|
||
declare param$adr address;
|
||
declare param based param$adr structure (
|
||
mem$top byte,
|
||
nmbcns byte,
|
||
breakpoint$restart byte,
|
||
add$sys$stack byte,
|
||
bank$switching byte,
|
||
Z80 byte,
|
||
banked$BDOS byte );
|
||
|
||
declare rlradr address;
|
||
declare rlr based rlradr address;
|
||
declare rlrcont address;
|
||
declare rlrpd based rlrcont process$descriptor;
|
||
|
||
declare dlradr address;
|
||
declare dlr based dlradr address;
|
||
|
||
declare drladr address;
|
||
declare drl based drladr address;
|
||
|
||
declare plradr address;
|
||
declare plr based plradr address;
|
||
|
||
declare slradr address;
|
||
declare slr based slradr address;
|
||
|
||
declare qlradr address;
|
||
declare qlr based qlradr address;
|
||
|
||
declare nmb$cns$adr address;
|
||
declare nmb$consoles based nmb$cns$adr byte;
|
||
|
||
declare cns$att$adr address;
|
||
declare console$attached based cns$att$adr (1) address;
|
||
|
||
declare cns$que$adr address;
|
||
declare console$queue based cns$que$adr (1) address;
|
||
|
||
declare nmbflags$adr address;
|
||
declare nmbflags based nmbflags$adr byte;
|
||
|
||
declare sys$flg$adr address;
|
||
declare sys$flag based sys$flg$adr (1) address;
|
||
|
||
declare nmb$seg$adr address;
|
||
declare nmb$segs based nmb$seg$adr byte;
|
||
|
||
declare mem$seg$tbl$adr address;
|
||
declare mem$seg$tbl based mem$seg$tbl$adr (1) memory$descriptor;
|
||
|
||
declare pdtbl$adr address;
|
||
declare pdtbl based pdtbl$adr (1) process$descriptor;
|
||
|
||
declare hex$digit (*) byte data ('0123456789ABCDEF');
|
||
|
||
declare queue$adr address;
|
||
|
||
declare queue based queue$adr structure (
|
||
cqueue,
|
||
owner$adr address );
|
||
|
||
display$hex$byte:
|
||
procedure (value);
|
||
declare value byte;
|
||
|
||
call co (hex$digit(shr(value,4)));
|
||
call co (hex$digit(value mod 16));
|
||
end display$hex$byte;
|
||
|
||
display$text:
|
||
procedure (count,text$adr);
|
||
declare count byte;
|
||
declare text$adr address;
|
||
declare char based text$adr byte;
|
||
declare i byte;
|
||
|
||
if count+char = 0 then return;
|
||
if count = 0 then
|
||
do;
|
||
call print$buffer (text$adr);
|
||
end;
|
||
else
|
||
do i = 1 to count;
|
||
call co (char and 7fh);
|
||
text$adr = text$adr + 1;
|
||
end;
|
||
end display$text;
|
||
|
||
display$links:
|
||
procedure (count,title$adr,root$adr);
|
||
declare count byte;
|
||
declare (title$adr,root$adr) address;
|
||
declare char based title$adr byte;
|
||
declare pd based root$adr process$descriptor;
|
||
declare i byte;
|
||
declare link$list (64) address;
|
||
declare (n,k) byte;
|
||
|
||
if count+char <> 0 then call crlf;
|
||
call display$text (count,title$adr);
|
||
if count+char = 0
|
||
then i = 0;
|
||
else i = 7;
|
||
n = -1;
|
||
disable; /* critical section required to obtain list */
|
||
do while (root$adr <> 0) and (n <> 63) and (high(root$adr) <> 0ffh);
|
||
link$list(n:=n+1) = root$adr;
|
||
root$adr = pd.pl;
|
||
end;
|
||
call mon1 (dispatch,0); /* enable interrupts by dispatching */
|
||
if n = -1 then return;
|
||
do k = 0 to n;
|
||
root$adr = link$list(k);
|
||
i = i + 1;
|
||
if i >= 8 then
|
||
do;
|
||
call crlf;
|
||
call co (' ');
|
||
i = 1;
|
||
end;
|
||
call co (' ');
|
||
call display$text (8,.pd.name);
|
||
if pd.memseg <> 0ffh then
|
||
do;
|
||
call co ('[');
|
||
call co (hex$digit(pd.console));
|
||
call co (']');
|
||
end;
|
||
end;
|
||
end display$links;
|
||
|
||
display$config:
|
||
procedure;
|
||
|
||
call display$text (0,
|
||
.(0dh,0ah,0dh,0ah,'Top of memory = ','$'));
|
||
call display$hex$byte (param.mem$top);
|
||
call display$text (0,
|
||
.('FFH',0dh,0ah,'Number of consoles = ','$'));
|
||
call display$hex$byte (nmb$consoles);
|
||
call display$text (0,
|
||
.(0dh,0ah,'Debugger breakpoint restart # = ','$'));
|
||
call display$hex$byte (param.breakpoint$restart);
|
||
if param.add$sys$stack then
|
||
do;
|
||
call display$text (0,
|
||
.(0dh,0ah,'Stack is swapped on BDOS calls','$'));
|
||
end;
|
||
if param.bank$switching then
|
||
do;
|
||
call display$text (0,
|
||
.(0dh,0ah,'Memory is bank switched','$'));
|
||
if param.banked$BDOS then
|
||
do;
|
||
call display$text (0,
|
||
.(0dh,0ah,'BDOS disk file management is bank switched','$'));
|
||
end;
|
||
end;
|
||
if param.Z80 then
|
||
do;
|
||
call display$text (0,
|
||
.(0dh,0ah,'Z80 complementary registers managed by dispatcher','$'));
|
||
end;
|
||
call crlf;
|
||
end display$config;
|
||
|
||
display$ready:
|
||
procedure;
|
||
|
||
call display$links (0,
|
||
.('Ready Process(es):','$'),rlr);
|
||
end display$ready;
|
||
|
||
display$DQ:
|
||
procedure;
|
||
|
||
call crlf;
|
||
call display$text (0,
|
||
.('Process(es) DQing:','$'));
|
||
queue$adr = qlr;
|
||
do while queue$adr <> 0;
|
||
if queue.dqph <> 0 then
|
||
do;
|
||
call display$text (4,.(0DH,0AH,' ['));
|
||
call display$text (8,.queue.name);
|
||
call co (']');
|
||
call display$links (0,.(0),queue.dqph);
|
||
end;
|
||
queue$adr = queue.ql;
|
||
end;
|
||
end display$DQ;
|
||
|
||
display$NQ:
|
||
procedure;
|
||
|
||
call crlf;
|
||
call display$text (0,
|
||
.('Process(es) NQing:','$'));
|
||
queue$adr = qlr;
|
||
do while queue$adr <> 0;
|
||
if queue.nqph <> 0 then
|
||
do;
|
||
call display$text (4,.(0DH,0AH,' ['));
|
||
call display$text (8,.queue.name);
|
||
call co (']');
|
||
call display$links (0,.(0),queue.nqph);
|
||
end;
|
||
queue$adr = queue.ql;
|
||
end;
|
||
end display$NQ;
|
||
|
||
display$delay:
|
||
procedure;
|
||
|
||
call display$links (0,
|
||
.('Delayed Process(es):','$'),dlr);
|
||
end display$delay;
|
||
|
||
display$poll:
|
||
procedure;
|
||
|
||
call display$links (0,
|
||
.('Polling Process(es):','$'),plr);
|
||
end display$poll;
|
||
|
||
display$flag$wait:
|
||
procedure;
|
||
declare i byte;
|
||
|
||
call crlf;
|
||
call display$text (0,
|
||
.('Process(es) Flag Waiting:','$'));
|
||
do i = 0 to nmbflags-1;
|
||
if sys$flag(i) < 0FFFEH then
|
||
do;
|
||
call crlf;
|
||
call co (' ');
|
||
call co (' ');
|
||
call display$hex$byte (i);
|
||
call display$text (3,.(' - '));
|
||
call display$links (0,.(0),sys$flag(i));
|
||
end;
|
||
end;
|
||
end display$flag$wait;
|
||
|
||
display$flag$set:
|
||
procedure;
|
||
declare i byte;
|
||
|
||
call crlf;
|
||
call display$text (0,
|
||
.('Flag(s) Set:','$'));
|
||
do i = 0 to nmbflags-1;
|
||
if sys$flag(i) = 0FFFEH then
|
||
do;
|
||
call crlf;
|
||
call co (' ');
|
||
call co (' ');
|
||
call display$hex$byte (i);
|
||
end;
|
||
end;
|
||
end display$flag$set;
|
||
|
||
display$queues:
|
||
procedure;
|
||
declare i byte;
|
||
|
||
queue$adr = qlr;
|
||
call crlf;
|
||
call display$text (0,
|
||
.('Queue(s):','$'));
|
||
i = 7;
|
||
do while queue$adr <> 0;
|
||
i = i + 1;
|
||
if i >= 8 then
|
||
do;
|
||
call crlf;
|
||
call co (' ');
|
||
i = 1;
|
||
end;
|
||
call co (' ');
|
||
call display$text (8,.queue.name);
|
||
if (queue.name(0) = 'M') and
|
||
(queue.name(1) = 'X') and
|
||
(queue.msglen = 0 ) and
|
||
(queue.nmbmsgs = 1 ) and
|
||
(queue.msgcnt = 0 ) then
|
||
do;
|
||
call co ('[');
|
||
call display$text (8,queue.owner$adr+6);
|
||
call co (']');
|
||
i = i + 1;
|
||
end;
|
||
queue$adr = queue.ql;
|
||
end;
|
||
call crlf;
|
||
end display$queues;
|
||
|
||
display$consoles:
|
||
procedure;
|
||
declare i byte;
|
||
declare name$offset literally '6';
|
||
|
||
call display$text (0,
|
||
.('Process(es) Attached to Consoles:','$'));
|
||
do i = 0 to nmb$consoles-1;
|
||
call display$text (5,.(0dh,0ah,' ['));
|
||
call co (hex$digit(i));
|
||
call display$text (4,.('] - '));
|
||
if console$attached(i) = 0
|
||
then call display$text (0,
|
||
.('Unattached','$'));
|
||
else call display$text (8,
|
||
console$attached(i) + name$offset);
|
||
end;
|
||
call display$text (0,.(0dh,0ah,
|
||
'Process(es) Waiting for Consoles:','$'));
|
||
do i = 0 to nmb$consoles-1;
|
||
if console$queue(i) <> 0 then
|
||
do;
|
||
call display$text (5,.(0dh,0ah,' ['));
|
||
call co (hex$digit(i));
|
||
call display$text (4,.('] - '));
|
||
call display$links (0,.(0),console$queue(i));
|
||
end;
|
||
end;
|
||
end display$consoles;
|
||
|
||
display$mem$seg:
|
||
procedure;
|
||
declare i byte;
|
||
|
||
call display$text (0,.(0dh,0ah,
|
||
'Memory Allocation:','$'));
|
||
do i = 0 to nmbsegs-1;
|
||
call display$text (0,
|
||
.(0dh,0ah,' Base = ','$'));
|
||
call display$hex$byte (memsegtbl(i).base);
|
||
call display$text (0,
|
||
.('00H Size = ','$'));
|
||
call display$hex$byte (memsegtbl(i).size);
|
||
call display$text (0,.('00','$'));
|
||
if param.bank$switching then
|
||
do;
|
||
call display$text (0,
|
||
.('H Bank = ','$'));
|
||
call display$hex$byte (memsegtbl(i).bank);
|
||
end;
|
||
if (memsegtbl(i).attrib and allocated) = 0 then
|
||
do;
|
||
call display$text (0,
|
||
.('H * Free *','$'));
|
||
end;
|
||
else
|
||
do;
|
||
if memsegtbl(i).attrib = 0ffh then
|
||
do;
|
||
call display$text (0,
|
||
.('H * Reserved *','$'));
|
||
end;
|
||
else
|
||
do;
|
||
call display$text (0,
|
||
.('H Allocated to ','$'));
|
||
call display$text (8,.pdtbl(i).name);
|
||
call co ('[');
|
||
call co (hex$digit(pdtbl(i).console));
|
||
call co (']');
|
||
end;
|
||
end;
|
||
end;
|
||
end display$mem$seg;
|
||
|
||
setup:
|
||
procedure;
|
||
|
||
datapgadr = (param$adr:=xdos (system$data$adr,0)) + 252;
|
||
datapgadr = datapg;
|
||
rlradr = datapgadr + osrlr;
|
||
rlrcont = rlr;
|
||
dlradr = datapgadr + osdlr;
|
||
drladr = datapgadr + osdrl;
|
||
plradr = datapgadr + osplr;
|
||
slradr = datapgadr + osslr;
|
||
qlradr = datapgadr + osqlr;
|
||
nmb$cns$adr = datapgadr + osnmbcns;
|
||
cns$att$adr = datapgadr + oscnsatt;
|
||
cns$que$adr = datapgadr + oscnsque;
|
||
nmbflags$adr = datapgadr + osnmbflags;
|
||
sys$flg$adr = datapgadr + ossysfla;
|
||
nmb$seg$adr = datapgadr + osnmbsegs;
|
||
mem$seg$tbl$adr = datapgadr + osmsegtbl;
|
||
pdtbl$adr = datapgadr + ospdtbl;
|
||
end setup;
|
||
|
||
|
||
declare ret byte;
|
||
|
||
declare last$dseg$byte byte
|
||
initial (0);
|
||
|
||
start:
|
||
call setup;
|
||
call crlf;
|
||
call crlf;
|
||
call display$text (0,
|
||
.('****** MP/M 1.1 Status Display ******','$'));
|
||
call display$config;
|
||
call display$ready;
|
||
call display$DQ;
|
||
call display$NQ;
|
||
call display$delay;
|
||
call display$poll;
|
||
call display$flag$wait;
|
||
call display$flag$set;
|
||
call display$queues;
|
||
call display$consoles;
|
||
call display$mem$seg;
|
||
ret = xdos (terminate,0);
|
||
|
||
end status;
|
||
|