/* Common Include Module for RSP and Transient CCPMSTAT */ $include(:f2:newcom.lit) dcl buff (128) byte external; mon1: procedure (func,info) external; dcl func byte; dcl info address; end mon1; mon2: procedure (func,info) byte external; dcl func byte; dcl info address; end mon2; mon3: procedure (func,info) address external; dcl func byte; dcl info address; end mon3; mon4: procedure (func,info) pointer external; dcl func byte; dcl info address; end mon4; patch: procedure; /* dummy area for patching code segments */ declare i address; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; end patch; dcl maxpd byte initial (63); /* Maximum # process descript's*/ dcl maxmd byte initial (80); /* Maximum # memory descriptors*/ dcl maxqflags byte initial (40h); /* Max Value for a queue flag */ dcl freename (*)byte initial ('* FREE *'); /* For free memory partitions */ dcl maxqueues byte initial (64); /* Maximum # of system queues */ dcl lbracket byte initial ('['); dcl rbracket byte initial (']'); dcl repeat byte; /* Controls continuous display */ dcl intrval word; /* Controls update timing */ dcl specified byte; /* Command Line argument flag */ dcl flaglen byte initial (3); /***************************************************************************/ /* */ /* Terminal-dependent Control Characters */ /* */ /***************************************************************************/ dcl clearseq (6) byte initial (2,01bh,'E',0,0,0); /* ESC E = clear screen*/ dcl homeseq (6) byte initial (2,01bh,'H',0,0,0); /* ESC H = home cursor */ dcl CR lit '13'; /* CR = carriage return*/ dcl LF lit '10'; /* LF = line feed */ $include (:f2:mdsat.lit) $include (:f2:proces.lit) $include (:f2:sd.lit) $include (:f2:qd.lit) $include (:f2:flag.lit) $include (:f2:uda.lit) $include (:f2:vccb.lit) /*$include (:f2:ccb.lit)*/ dcl pd$pointer pointer; /* double word bases for MP/M-86 data structures */ dcl pd$ptr structure( offset word, segment word) at (@pd$pointer); dcl pd based pd$pointer pd$structure; dcl qd$pointer pointer; dcl qd$ptr structure( offset word, segment word) at (@qd$pointer); dcl qd based qd$pointer qd$structure; dcl md$pointer pointer; dcl md$ptr structure( offset word, segment word) at (@md$pointer); dcl md based md$pointer md$structure; dcl ms$pointer pointer; dcl ms$ptr structure( offset word, segment word) at (@ms$pointer); dcl ms based ms$pointer ms$structure; dcl sat$pointer pointer; dcl sat$ptr structure( offset word, segment word) at (@sat$pointer); dcl sat based sat$pointer sat$structure; dcl flag$pointer pointer; dcl flag$ptr structure( offset word, segment word) at (@flag$pointer); dcl flag based flag$pointer flag$structure; dcl vccb$pointer pointer; dcl vccb$ptr structure ( offset word, segment word) at (@vccb$pointer); dcl vccb based vccb$pointer ccb$structure; dcl uda$pointer pointer; dcl uda$ptr structure ( offset word, segment word) at (@uda$pointer); dcl uda based uda$pointer uda$structure; /* BDOS Calls */ reboot: procedure; call mon1(0,0); end reboot; conin: procedure byte; return(mon2(1,0)); end conin; co: procedure (char); dcl char byte; call mon1 (2,char); end co; rawconin: procedure byte; return mon2(6,0fdh); end rawconin; constat: procedure byte; return(mon2(11,0)); end constat; rawco: procedure (char); dcl char byte; call mon1(6,char); end rawco; delay: procedure (num); dcl num address; call mon1(141,num); end delay; print$buffer: procedure (bufferadr); dcl bufferadr address; call mon1 (9,bufferadr); end print$buffer; get$version: procedure word; return mon3(12,0); end get$version; terminate: procedure; call mon1(143,0); end terminate; get$sysdat: procedure pointer; return mon4(154,0); end get$sysdat; get$currpd: procedure pointer; return mon4(156,0); end get$currpd; /* utility functions */ crlf: procedure; call co (CR); call co (LF); end crlf; print$infield: /* Prints 'len' # of bytes in a */ /* left- or right-justified field*/ /* of 'width' dimension. */ procedure (width,justify,len,dataddr); dcl dataddr pointer; dcl (width,len) byte, (i,justify) byte; dcl char based dataddr byte; dcl dat$ptr structure( offset word, segment word) at (@dataddr); if len <= width then do; /* Error Check */ if justify = 'r' then /* Right Justify */ do i=1 to (width-len) ; /* Pad on the left */ call co(' '); end; do i=1 to len ; call co (char and 7fh); /* Print the data */ dat$ptr.offset = dat$ptr.offset + 1; end; if justify = 'l' then /* Left-justified*/ do i = 1 to (width-len); /* Pad on the right*/ call co(' '); end; end; end print$infield; dcl hex$digit (*) byte data ('0123456789ABCDEF'); display$hex$byte: procedure (value); dcl value byte; call co (hex$digit(shr(value,4))); call co (hex$digit(value mod 16)); end display$hex$byte; display$hex$word: procedure (value); dcl value word; call display$hex$byte (high(value)); call display$hex$byte (low (value)); end display$hex$word; print$hex$byte: /* Prints hex byte in a right- or */ /* left-justified field of 'width'*/ /* dimension. */ procedure (width,justify,val); dcl (val,width) byte, (i,justify) byte; if width < 2 then return; /* Must be at least 2 for hex byte */ else do; if justify = 'r' then /* Right Justify */ do i=1 to (width - 2) ; call co(' '); /* Pad on the left */ end; call display$hex$byte(val); /* Print the digits */ if justify = 'l' then do i=1 to (width-2) ; call co(' '); /* Pad on the right */ end; end; end print$hex$byte; print$hex$word: /* Prints hex word in a right- */ /* or left-justified field of */ /* 'width' dimension. */ procedure(width,justify,val); dcl val word, (justify,width) byte; dcl i byte; if width < 4 then return; /* Error check */ else do; if justify = 'r' then /* Field is right-justified */ do i=1 to (width-4) ; call co(' '); /* Pad on the left */ end; call display$hex$word(val); /* Print the digits */ if justify = 'l' then do i=1 to (width-4) ; call co(' '); /* Pad on the right */ end; end; end print$hex$word; clear: procedure; dcl i byte; do i = 1 to clearseq(0); /* 1st element = counter */ call rawco(clearseq(i)); /* Direct clear_screen sequence */ end; /* to terminal. */ end clear; home: procedure; dcl i byte; do i = 1 to homeseq(0); /* 1st element = counter */ call rawco(homeseq(i)); /* direct home cursor sequence */ end; /* to terminal. */ end home; skip$lines: procedure(numlines); dcl (numlines,i) byte; do i = 1 to numlines; call co(LF); end; end skip$lines; cons$wait: procedure; dcl chr byte; call print$buffer(.(CR,LF, ' Type any key to leave and return to main menu.$')); chr = conin; end cons$wait; aschex: /* Convert ascii to hex*/ procedure(num) byte; dcl num byte; if (num > 47) and (num < 58) then do; /* 0 - 9 range */ num = num - '0'; end; else do; if (num > 64) and (num < 71) then do; /* A - F range */ num = num - 55; end; else do; if (num > 96) and (num < 103) then do; /* a - f range */ num = num - 87; end; else num = 015h; /* Error -> Default */ end; end; return (num); end aschex; get$intrval: procedure word; dcl (chr,chr1) byte, ticdelay word; /* Find out if user wants continuous */ /* and if so, how short an interval */ call crlf;call print$buffer(.(CR,LF,' Continuous Display?$')); chr = conin; if (chr = 'y') or (chr = 'Y') then do; repeat = true; call print$buffer(.(CR,LF,'Time Interval (in hex) :$')); chr = conin; if (chr <> LF) and (chr <> CR) then do; /* It's not a default */ chr = aschex(chr); /* Get true hex version */ chr1 = conin; /* wait for CR or LF */ if (chr1 <> LF) and (chr1 <> CR) then do; /* 2nd hex digit */ chr = shl(chr,4) + aschex(chr1); chr1 = conin; /* Get this CR LF */ end; end; else chr = 01h; /* Default value */ ticdelay = chr * (sd.tickspersec); /* Convert to system ticks */ end; return (ticdelay); end get$intrval; disp$mainhdr: procedure; /* Main Menu Display */ call home; call clear; call crlf; call crlf; call print$infield(34,'r',14,@('Which Option ?')); call crlf; call crlf; call print$infield(33,'r',7,@('H (elp)')); call crlf; call print$infield(35,'r',9,@('M (emory)')); call crlf; call print$infield(37,'r',11,@('O (verview)')); call crlf; call print$infield(44,'r',18,@('P (rocesses - all)')); call crlf; call print$infield(35,'r',9,@('Q (ueues)')); call crlf; call print$infield(43,'r',17,@('U (ser processes)')); call crlf; call print$infield(37,'r',11,@('C (onsoles)')); call crlf; call print$infield(33,'r',7,@('E (xit)')); call crlf; call crlf; call print$infield(26,'r',2,@('->')); end disp$mainhdr; print$opt$err: procedure; call print$buffer(.(CR,LF,' Illegal command tail.$')); call crlf; call terminate; end print$opt$err; display$help: procedure; call home; call clear; call crlf; call crlf; call crlf; call print$infield(42,'r',23,@('VALID SYSTAT COMMANDS :')); call crlf; call crlf; call print$infield(25,'r',6,@('SYSTAT')); call crlf; call print$infield(34,'r',15,@('SYSTAT [OPTION]')); call crlf; call print$infield(36,'r',17,@('SYSTAT [OPTION C]')); call crlf; call print$infield(39,'r',20,@('SYSTAT [OPTION C ##]')); call crlf; call crlf; call print$infield(28,'r',9,@('- where -')); call crlf; call crlf; call print$infield(44,'r',25,@('-> C = continuous display')); call crlf; call print$infield(47,'r',28,@('-> ## = 1-2 digit hex timer.')); call crlf; call crlf; call print$infield(30,'r',11,@('-> OPTION =')); call crlf; call print$infield(67,'r',44,@('M(emory) P(rocesses) O(verview) C(onsoles)')); call crlf; call print$infield(56,'r',33,@('U(ser Processes) Q(ueues) H(elp)')); call crlf; if not(specified) then call cons$wait; else call terminate; end display$help; prntheader: procedure; /* Used in Process Data Display */ call home; call clear; call print$infield(20,'r',18,@('Virtual Process')); call crlf; call print$infield(20,'r',18,@('Console Name ')); call print$infield(37,'r',35,@('Flag Prior Status Resource')); call crlf; call print$infield(20,'r',18,@('------- -------')); call print$infield(37,'r',35,@('---- ----- ------ --------')); end prntheader; disp$status: procedure(stat); /* Prints formatted status field */ dcl stat byte; /* of Process display. */ if (stat >=0) and (stat < 11) then do; do case stat; call print$infield(13,'l',5,@('READY')); call print$infield(13,'l',4,@('POLL')); call print$infield(13,'l',5,@('DELAY')); call print$infield(13,'l',4,@('SWAP')); call print$infield(13,'l',9,@('TERMINATE')); call print$infield(13,'l',5,@('SLEEP')); call print$infield(13,'l',7,@('READING')); call print$infield(13,'l',7,@('WRITING')); call print$infield(13,'l',9,@('FLAG WAIT')); call print$infield(13,'l',8,@('CIO WAIT')); call print$infield(13,'l',8,@('SYNCHING')); end; end; else call print$infield(13,'l',5,@('ERROR')); end disp$status; disp$resource: procedure(stats,rsrce);/* Prints formatted resource field */ dcl stats byte; /* of Process display. */ dcl (rsrce,offs) word; dcl (count,notfound) byte; /* For flag table traversal */ if (stats >=0) and (stats < 11) then do; do case stats; call print$infield(13,'l',3,@('CPU ')); /* Case 0 */ do; /* Case 1 */ call print$infield(8,'l',8,@('DEVICE #')); call print$hex$byte(4,'l',low(rsrce)); end; do; /* Case 2 */ call print$infield(8,'l',8,@('TICKS = ')); call print$hex$word(4,'l',rsrce); end; call print$infield(13,'l',7,@('SWAPERR ')); /* Case 3 */ call print$infield(13,'l',3,@('CPU ')); /* Case 4 */ do; if rsrce = sd.rlr then /* Case 5 */ call print$infield(13,'l',10,@('READY LIST')); else if rsrce = sd.dlr then call print$infield(13,'l',10,@('DELAY LIST')); else if rsrce = sd.drl then call print$infield(13,'l',10,@('DISPATCHER')); else if rsrce = sd.plr then call print$infield(13,'l',9,@('POLL LIST')); else call print$infield(13,'l',5,@('OTHER')); end; do; /* Case 6 */ qd$ptr.offset = rsrce; call print$in$field(12,'l',pnamsiz,@qd.name); end; do; /* Case 7 */ qd$ptr.offset = rsrce; call print$infield(12,'l',pnamsiz,@qd.name); end; do; /* Case 8 */ call co(023h); /* A '#' sign */ if rsrce <> 0ffffh then call print$hex$byte(12,'l',low(rsrce)); else call print$in$field(12,'l',1,@('?')); end; do; /* Case 9 */ call print$infield(10,'l',9,@('CONSOLE #')); call display$hex$byte(low(rsrce)); end; call print$infield(13,'l',13,@(' ')); /* Case 10*/ end; /* case */ end; else /* Invalid Status Value */ call print$infield(12,'l',5,@('ERROR')); end disp$resource; dcl pd$list (64) structure ( /* Stores fields of successive pd's.*/ cns byte, name (8) byte, flag word, prior byte, stat byte , resource word); dcl link$list (64) word; display$proc: procedure(lnkfield); dcl lnkfield byte; /* True = user proc's only,False = all proc's*/ dcl (char,temp) byte; /* Temp controls continuous printout */ dcl (k,n) byte, (notfound,i) byte; if not(specified) then intrval = get$intrval; /* Find out from user what kind of display */ temp = true; call prntheader; do while (temp or repeat); /* Display until user hits any key */ disable; /* critical section required to obtain list*/ temp = false; n = -1; pd$ptr.offset = sd.thrdrt; /* Start at Thread List root. */ getpds: /* Put all pd's on the list */ do while (pd$ptr.offset <> 0) and (n <> maxpd); n = n + 1; if not(lnkfield) or (pd.mem <> 0) then /* Is it user processes only ? */ do; /* Either display all processes anyway or */ /* or this is a valid user process. */ pd$list(n).cns = pd.cns; do i= 0 to pnamsiz-1; pd$list(n).name(i) = pd.name(i); end; pd$list(n).flag = pd.flag; pd$list(n).prior = pd.prior; pd$list(n).stat = pd.stat; /* Use sysdat info to determine what each*/ /* process is waiting for or using. Get */ /* Queue names,flag #'s,system ticks,list*/ /* names and device or console #'s. Must */ /* be done in critical region. */ i = pd.stat; /* Save this to determine resource . */ if (i = 1) or (i = 2 )then pd$list(n).resource = pd.wait; /* Device # or # of ticks delayed */ else if i = 5 then /* Process is sleeping - find out which list*/ do; uda$ptr.segment = pd.uda; uda$ptr.offset = 0; pd$list(n).resource = uda.dparam; end; else if (i = 6) or (i = 7) then /* Process is reading from or writing to */ do; /* a queue. Get address of queue name. */ uda$ptr.segment = pd.uda; uda$ptr.offset = 0; if i = 6 then pd$list(n).resource = (uda.dparam) - 12h; else pd$list(n).resource = (uda.dparam) - 14h; end; else if i = 8 then /* Process is waiting on a flag, get the #*/ do; pd$list(n).resource = 0ffffh; /* Remains if no flag found .*/ flag$ptr.offset = sd.flags; notfound = true; k = 0; /* Flag counter */ do while notfound; if (flag.pd <> pd$ptr.offset) then do; k = k+ 1; flag$ptr.offset = flag$ptr.offset + flaglen; if k > sd.nflags then /* End of table */ notfound = false; end; else /* This is the flag*/ do; pd$list(n).resource = k; notfound = false; end; end; end; else if i = 9 then do; pd$list(n).resource = pd.cns; end; end; /* Valid processes*/ else n = n-1; /* Ignore system processes */ pd$ptr.offset = pd.thread; /* Get the next process*/ end getpds; if n = -1 then return; /* stop here if no pds */ enable; call home; call skip$lines(3); /* enables interrupts */ printpds: do k = 0 to n; if k <> 0 then call crlf; call print$hex$byte(7,'r',pd$list(k).cns);/* print virtual console #*/ call print$buffer(.(' $')); call print$infield(9,'l',pnamsiz,@pd$list(k).name); /* print name */ call print$hex$word(8,'l',pd$list(k).flag); call print$hex$byte(7,'l',pd$list(k).prior); /* print its priority */ call disp$status(pd$list(k).stat); /* print process status */ call disp$resource(pd$list(k).stat,pd$list(k).resource); /* print resource */ end printpds; if n < 21 then do; do k = n to 18; call print$buffer(.(CR,LF, ' $')); end; end; if constat then do; /* Check for User Interrupt*/ repeat = false; char = conin; /* Swallow stop char */ end; if repeat then do; /* If still going,delay it */ call delay(intrval); /* and go back to loop top */ if (n >= 20) then call prntheader; end; else do; if not(specified) then /* If not comline args then */ call cons$wait; /* let them get to main menu*/ else call terminate; end; end;/*while loop*/ end display$proc; dcl sortrecd structure ( name (8) byte, /* Stores data when sorting*/ start word, pd word, len word, cns byte ); dcl sortarray (80) structure ( /* For sorting and printing*/ name (8) byte, start word, pd word, len word, cns byte ); dcl sharearray (80) structure ( /* For Shared Code List */ name (8) byte, start word, disk byte, user byte, len word, cns byte ); disp$memhdr : procedure; call home; call clear; call print$buffer(.('Process Virtual | $')); call print$buffer(.('Process Virtual $')); call print$buffer(.(CR,LF,' Name Console PD# Start Len | $')); call print$buffer(.(' Name Console PD# Start Len $')); call print$buffer(.(CR,LF,'________ _______ ____ _____ ____ | $')); call print$buffer(.(' _______ _______ ____ _____ ____$')); end disp$memhdr; print$sorted: /* Prints two columns of memory data */ procedure(cnt,scnt); /* Uses sorted array of structures. */ dcl (cnt,scnt) byte, /* cnt: regular mem,scnt: shared mem */ (m,q,k) byte; call home; call skip$lines(3); if (cnt > 1) then do; /* Must have two per line here */ do m = 0 to ((cnt/2)-1) ; /* If odd #, hold last one */ if m > 0 then call crlf; /* Print 2 columns,ascending values*/ k = m; do q = 1 to 2 ; call print$infield(12,'l',pnamsiz,@sortarray(k).name); if sortarray(k).cns = 030h then call print$buffer(.(' $')); else call print$hex$byte(7,'l',sortarray(k).cns); call print$hex$word(6,'l',sortarray(k).pd); call print$hex$word(7,'l',sortarray(k).start); call print$hex$word(5,'l',sortarray(k).len); if (q mod 2) <> 0 then call print$buffer(.('| $')); k = k + (cnt/2); /* Go to other half of the array */ end; end; end; if (cnt mod 2) <> 0 then do; /* Only put one on last line */ /* Print blanks on left */ call print$buffer(.(CR,LF, ' | $')); call print$infield(12,'l',pnamsiz,@sortarray(cnt-1).name); if sortarray(cnt-1).cns = 030h then call print$buffer(.(' $')); else call print$hex$byte(7,'l',sortarray(cnt-1).cns); call print$hex$word(6,'l',sortarray(cnt-1).pd); call print$hex$word(7,'l',sortarray(cnt-1).start); call print$hex$word(5,'l',sortarray(cnt-1).len); end; /* Print Shared Code,if any */ if (scnt > 0) then do; call print$buffer(.(CR,LF, ' Shared Code List $')); call print$buffer(.(' $')); end; if (scnt > 1) then do; /* At least 1 full line to display .*/ do m = 0 to ((scnt/2) - 1); /* If there's an odd # of partitions*/ call crlf; /* this will print all but last one.*/ k = m; do q = 1 to 2; call print$infield(12,'l',pnamsiz,@sharearray(k).name); if sharearray(k).cns = 030h then call print$buffer(.(' $')); else call print$hex$byte(7,'l',sharearray(scnt-1).cns); call print$hex$byte(2,'l',sharearray(k).disk); call print$hex$byte(4,'l',sharearray(k).user); call print$hex$word(7,'l',sharearray(k).start); call print$hex$word(5,'l',sharearray(k).len); if (q mod 2) <> 0 then call print$buffer(.('| $')); k = k + (scnt/2); end; end; end; if (scnt > 0) then do; /* Check if one is left */ if (scnt mod 2) <> 0 then do; /* Odd # of md's. */ /* Put just 1 on last line*/ call print$buffer(.(CR,LF, ' | $')); call print$infield(12,'l',pnamsiz,@sharearray(scnt-1).name); if sharearray(scnt-1).cns = 030h then call print$buffer(.(' $')); else call print$hex$byte(7,'l',sharearray(scnt-1).cns); call print$hex$byte(2,'l',sharearray(scnt-1).disk); call print$hex$byte(4,'l',sharearray(scnt-1).user); /*** call print$infield(13,'r',13, @('** **** $')); ***/ call print$hex$word(7,'l',sharearray(scnt-1).start); call print$hex$word(5,'l',sharearray(scnt-1).len); end; scnt = scnt + 1; /* Count its heading */ end; if ((cnt+scnt)/2) < 21 then do; /* Clear rest of screen */ do k = ((cnt+scnt)/2) to 18; call print$buffer(.(CR,LF, ' $')); call print$buffer(.(' $')); end; end; end print$sorted; display$mem: procedure; dcl (i,mdcnt,pdcnt) byte; /* Mdcnt = memory descriptor count*/ dcl (x,y) byte, /* Pdcnt = process descr. count */ (cont,scdcnt) byte, /* cont = Boolean 'continue' */ n integer, (temp,chr) byte, savmau word; if not(specified) then intrval = get$intrval; /* Get hex value from terminal */ temp = true; call home; call clear; call disp$memhdr; do while (temp or repeat); /* Display at least once */ temp = false; do pdcnt = 0 to maxpd; link$list(pdcnt) = 0; end; n = -1; pdcnt = 0; disable; /* Critical section required to obtain list */ getmemowners: pd$ptr.offset = sd.thrdrt; /* Start at Thread Root */ do while (pd$ptr.offset <> 0) and (pdcnt <> maxpd); if pd.mem <> 0 then do; /* If it owns memory, */ link$list(n:=n+1) = pd$ptr.offset; /* put it on the list. */ pdcnt = pdcnt + 1; end; pd$ptr.offset = pd.thread; /* Go to next process */ end; if pdcnt = 0 then return; getmds: mdcnt = 0; do i = 0 to (pdcnt-1); pd$ptr.offset = link$list(i); /* Reset Proc Descriptor */ ms$ptr.offset = pd.mem; cont = true; do while (cont and (mdcnt <= maxmd)); sortarray(mdcnt).pd = pd$ptr.offset; /* Get proc descriptor */ cont = false; md$ptr.offset = ms.mau; /* Md is on MAL */ sortarray(mdcnt).start = md.start; sortarray(mdcnt).len = md.length; sortarray(mdcnt).cns = pd.cns; do x = 0 to 7; /* Get owner's name */ sortarray(mdcnt).name(x) = pd.name(x); /* A byte at a time */ end; if ms.link <> 0 then do; /* More md's for this */ /* process ? */ savmau = ms.mau; ms$ptr.offset = ms.link; do while (ms.mau = savmau) and (ms.link <> 0); savmau = ms.mau; /* Look for a different */ ms$ptr.offset = ms.link; /* partition,same pd. */ end; if (savmau <> ms.mau) then /* Check if same mau */ cont = true; /* If not, go get another md*/ end; mdcnt = mdcnt + 1; end; /* while cont : a single pd's memory*/ end; /* All pd's memory*/ /* That's all the used memory. Now go */ /* to the Memory Free List. */ md$ptr.offset = sd.mfl; do while md$ptr.offset <> 0 and (mdcnt < maxmd); do x = 0 to 7; sortarray(mdcnt).name(x) = freename(x); /*Use 'FREE' as name*/ end; sortarray(mdcnt).start = md.start; sortarray(mdcnt).pd = 0; sortarray(mdcnt).len = md.length; sortarray(mdcnt).cns = 030h; mdcnt = mdcnt+1; md$ptr.offset = md.link; end; /* Get shared code */ getshared: /* Free and used */ n = -1; pdcnt = 0; scdcnt = 0; pd$ptr.offset = sd.slr; /* Top of shared list*/ do while (pd$ptr.offset <> 0) and (pdcnt < maxpd); link$list(n:=n + 1) = pd$ptr.offset; pdcnt = pdcnt + 1; pd$ptr.offset = pd.thread; end; if (pdcnt > 0) then do; do i = 0 to (pdcnt-1); pd$ptr.offset = link$list(i); ms$ptr.offset = pd.mem; cont = true; do while (cont and (scdcnt < maxmd)); cont = false; sharearray(scdcnt).cns = pd.cns; ; sharearray(scdcnt).disk = pd.ldsk; ; sharearray(scdcnt).user = pd.luser; md$ptr.offset = ms.mau; sharearray(scdcnt).start = md.start; sharearray(scdcnt).len = md.length; /***** The follow is not needed as the code after sortmds will put in process name or free if pd.prior = 0 then do; do x = 0 to (pnamsiz - 1); sharearray(scdcnt).name(x) = freename(x); end; end; else do; do x = 0 to (pnamsiz - 1); sharearray(scdcnt).name(x) = pd.name(x); end; end; *****/ if (ms.link <> 0) then do; savmau = ms.mau; ms$ptr.offset = ms.link; do while (ms.mau = savmau) and (ms.link <> 0); savmau = ms.mau; ms$ptr.offset = ms.link; end; if (ms.mau <> savmau) then cont = true; end; scdcnt = scdcnt + 1; end; end; end; enable; /* End critical section */ /* Now sort the list of partitions */ sortmds : do x = 0 to (mdcnt-1); sortrecd.start = sortarray(x).start; do i = 0 to 7; sortrecd.name(i) = sortarray(x).name(i); end; sortrecd.len = sortarray(x).len; sortrecd.pd = sortarray(x).pd; sortrecd.cns = sortarray(x).cns; y = x; find : do while (y > 0) and ( sortarray(y-1).start > sortrecd.start); sortarray(y).start = sortarray(y-1).start; do i = 0 to 7; sortarray(y).name(i) = sortarray(y-1).name(i); end; sortarray(y).len = sortarray(y-1).len; sortarray(y).pd = sortarray(y-1).pd; sortarray(y).cns = sortarray(y-1).cns; y = y-1; end find; sortarray(y).start = sortrecd.start; do i = 0 to 7; sortarray(y).name(i) = sortrecd.name(i); end; sortarray(y).len = sortrecd.len; sortarray(y).pd = sortrecd.pd; sortarray(y).cns = sortrecd.cns; end sortmds; /* This code has been added to show when an shaered code memory block is free to be given to a new process */ if (pdcnt>0) then do; do i=0 to (pdcnt-1); x=0; do while ((sharearray(i).start >= (sortarray(x).start+sortarray(x).len)) and (x= 20) then call disp$memhdr; call delay(intrval); end; else do; if not(specified) then /* Get back to main menu*/ call cons$wait; else /* Skip menu, -> system */ call terminate; end; end;/*while*/ end display$mem; dcl qlist (64) structure ( name (8) byte, nmsgs word, msglen word, msgcnt word, nq word, dq word, owner (8) byte, flags byte); print$qhdr: procedure; /* Print Queue Heading */ call home; call clear; call print$buffer(.(' NAME NMSGS MSGLEN MSGCNT $')); call print$buffer(.('READER WRITER MX-OWNER FLAGS $')); call crlf; call print$buffer(.(' ________ ______ ______ ______ $')); call print$buffer(.('______ ______ ________ _____ $')); call crlf; end print$qhdr; display$flag$status: /* Print Queue Flag Status*/ procedure(flag); dcl prev boolean; dcl (i,flag,cnt) byte; prev = false; i = 1; cnt = 0; do while (i <= maxqflags) ; if (flag and i) <> 0 then do; if prev then do; /* Take care of formatting */ call co(','); cnt = cnt + 1; /* Count all chars */ end; call display$hex$byte(i); cnt = cnt + 2; prev = true; end; i = i*2; /* Flags are 1 bit each */ end; do i = cnt to 14; /* Clear previous line's flags */ call co(' '); end; end display$flag$status; display$queue: procedure; dcl temp byte, n integer, (qdcnt,cont) byte, (chr,i) byte; if not(specified) then intrval = get$intrval; temp = true; call print$qhdr; do while ( temp or repeat); temp = false; qdcnt = 0; call home; call skip$lines(2); getqueues: disable; /* Begin Critical Section */ qd$ptr.offset = sd.qlr; do while ((qdcnt < maxqueues) and (qd$ptr.offset <> 0)) ; do i = 0 to pnamsiz-1; qlist(qdcnt).name(i)= qd.name(i); end; qlist(qdcnt).nmsgs = qd.nmsgs; qlist(qdcnt).msglen = qd.msglen; qlist(qdcnt).msgcnt = qd.msgcnt; qlist(qdcnt).nq = qd.nq; qlist(qdcnt).dq = qd.dq; if ((qd.flags mod 2) <> 0) then do; /* It's an MX queue */ pd$ptr.offset = qd.buffer; if pd$ptr.offset <> 0 then /* It has an owner */ do i = 0 to pnamsiz -1; qlist(qdcnt).owner(i) = pd.name(i); end; else /* No one owns it now */ do i = 0 to pnamsiz-1; /* Print blanks */ qlist(qdcnt).owner(i) = ' '; end; end; else /* It's not an MX queue*/ do i = 0 to pnamsiz-1; qlist(qdcnt).owner(i) = ' '; end; qlist(qdcnt).flags = qd.flags; qdcnt = qdcnt + 1; qd$ptr.offset = qd.link; end; enable; /* End critical section */ print$qds: /* Print the Queue info */ do i = 0 to qdcnt-1; call print$buffer(.(' $')); call print$infield(11,'l',pnamsiz,@qlist(i).name);/* Queue Name */ call print$hex$word(8,'l',qlist(i).nmsgs); /* Number of Msgs*/ call print$hex$word(8,'l',qlist(i).msglen); /* Message Length*/ call print$hex$word(7,'l',qlist(i).msgcnt); /* Message Count */ pd$ptr.offset = qlist(i).dq; if pd$ptr.offset <> 0 then call print$infield(9,'l',pnamsiz,@pd.name); else call print$buffer(.(' $')); pd$ptr.offset = qlist(i).nq; if pd$ptr.offset <> 0 then call print$infield(9,'l',pnamsiz,@pd.name); else call print$buffer(.(' $')); call print$infield(10,'l',pnamsiz,@qlist(i).owner); /* Print it */ call display$flag$status(qlist(i).flags); /* Print Flag Value*/ call crlf; end; /* Print the Flag Key */ call print$buffer(.(' Flag Values : 1 = MX, 2 = NO DELETE, $')); call print$buffer(.('4 = NOT USER WRITEABLE, $')); call crlf; call print$buffer(.(' 8 = RSP, 10 = FROM QD TABLE, 20 = RPL QUEUE, $')); call print$buffer(.('40 = DEVICE QUEUE.$')); qdcnt = qdcnt - 1; /* To normalize */ if (qdcnt < 22) then do; do i = qdcnt to 17; call print$buffer(.(CR,LF, ' $')); end; end; if constat then do; /* Check for continue */ repeat = false; chr = conin; end; if repeat then do; /* Keep going,delay first */ call delay(intrval); if (qdcnt >= 19) then do; call print$qhdr; end; end; else do; /* Stop display */ if not(specified) then /* Go to main menu */ call cons$wait; else /* Go back to system */ call terminate; end; end; /* while loop */ end display$queue; dcl cns$list (32) structure ( phys byte, virt byte, state word, name (8) byte); print$cnshdr: procedure; call home; call clear; call print$infield(20,'r',20,@(' PHYSICAL VIRTUAL$')); call crlf; call print$infield(20,'r',20,@(' CONSOLE CONSOLE$')); call print$infield(39,'l',18,@(' NAME STATE$')); call crlf; call print$infield(20,'r',20,@(' -------- -------$')); call print$infield(39,'l',18,@(' -------- -----$')); call crlf; end print$cnshdr; display$cons: procedure(vers); dcl (vers,char) byte; dcl (count,index) byte; dcl temp byte; dcl state word; if vers then do; call home; call clear; call crlf; call crlf; call print$buffer(.('Not implemented for MP/M-86 2.1 $')); return; end; index = 0; if not(specified) then /* If user has not used com line specs */ intrval = get$intrval; /* see if continuous display is needed */ temp = true; call print$cnshdr; do while (temp or repeat); /* Do at least once and */ disable; /* maybe keep going until */ vccb$ptr.offset = sd.ccb; /* user hits a key to stop */ temp = false; do count = 0 to (sd.ncns - 1); /* Do all vccbs */ cns$list(count).phys = vccb.pc; /* Get the physical cons # */ cns$list(count).virt = vccb.vc; /* Get virtual console # */ cns$list(count).state = vccb.state; /* Get state word */ if vccb.attach <> 0 then do; /* If owned, get owner name */ pd$ptr.offset = vccb.attach; /* Attach = owner's offset */ do index = 0 to pnamsiz - 1; cns$list(count).name(index) = pd.name(index); end; end; else /* Else no one owns it */ cns$list(count).name(0) = 0; /* We'll print "FREE" later*/ vccb$ptr.offset = vccb$ptr.offset + vccb$len ; end; enable; /* Now interpret and print */ call home; call skip$lines(3); print$cns: do count = 0 to (sd.ncns - 1); call print$hex$byte(7,'r',cns$list(count).phys); /* Physical # */ call print$hex$byte(10,'r',cns$list(count).virt); /* Virtual # */ if cns$list(count).name(0) = 0 then /* No one owns this one*/ call print$infield(13,'r',8,@freename); else call print$infield(13,'r',8,@cns$list(count).name); /* Now print its states */ state = cns$list(count).state; if ((state and 02h) <> 0) /* either foregr or backgr*/ then call print$infield(6,'r',5,@(' BACK')); else call print$infield(6,'r',5,@(' FORE')); if ((state and 01h) <> 0) /* either buffered or dyna*/ then call print$infield(5,'r',5,@(',BUFF')); else call print$infield(5,'r',5,@(',DYNA')); if ((state and 04h) <> 0) then /* It's purging */ call print$infield(8,'r',8,@(',PURGING')); if ((state and 08h) <> 0) then /* It's in Noswitch mode */ call print$infield(8,'r',8,@(',NOSWTCH')); if ((state and 010h) <> 0) then /* It's suspended */ call print$infield(5,'r',5,@(',SUSP')); if ((state and 020h) <> 0) then /* It's owner is terminating */ call print$infield(6,'r',6,@(',ABORT')); if ((state and 040h) <> 0) then /* It's in filefull mode */ call print$infield(9,'r',9,@(',FILEFULL')); if ((state and 080h) <> 0) then /* It's in ^S mode */ call print$infield(3,'r',3,@(',^S')); if ((state and 0100h) <> 0) then /* It's in ^O mode */ call print$infield(3,'r',3,@(',^O')); if ((state and 0200h) <> 0) then /* It's in ^P mode */ call print$infield(3,'r',3,@(',^P')); call print$infield(15,'r',1,@(' '));/* Clear rest of line */ call crlf; end; if sd.ncns < 21 then do; do index = sd.ncns to 18; call print$buffer(.(CR,LF, ' $')); end; end; if constat then do; repeat = false; char = conin; end; if repeat then do; call delay(intrval); if (sd.ncns >= 20) then call print$cnshdr; end; else do; if not(specified) then call cons$wait; else call terminate; end; end; /* while loop */ end display$cons; dcl driv$letter (*) byte data ('ABCDEFGHIJKLMNOP'); display$gen: procedure(vers); /* Overview Display Routine*/ dcl vers byte; dcl (count,qsize) word; dcl mode word; call home; call clear; pd$pointer = get$currpd; /* Get PD for Current Process*/ vccb$ptr.offset = sd.ccb + (pd.cns * size(vccb)); call crlf; call print$infield(42,'r',17,@('Default Disk = ')); call co(driv$letter(pd.dsk)); call co(':'); call crlf; call print$infield(42,'r',24,@('Default User Number = ')); call display$hex$byte(pd.user); call crlf; call print$infield(42,'r',20,@('Default Printer = ')); if (vers) then /* It's MPM-86 */ call display$hex$byte(pd.lst - sd.ncondev); else /* It's Concurrent */ call display$hex$byte(pd.lst); if (vers) then do; /* It's MP/M-86 */ call crlf; call print$infield(42,'r',29,@('Current Physical Console = ')); end; else do; call crlf; call print$infield(42,'r',28,@('Current Virtual Console = ')); end; call display$hex$byte(pd.cns); if (not vers) then do; call crlf;call print$infield(42,'r',20,@('Background Mode = ')); mode = (vccb.state); if (mode >= 0) and (mode <= 0200h ) then do; if (mode mod 2) = 0 then call print$buffer(.('DYNAMIC $')); else call print$buffer(.('BUFFERED$')); end; else call print$buffer(.('OTHER $')); end; if (not vers) then do; call crlf; call print$infield(42,'r',17,@('Buffer Space = ')); call display$hex$word(vccb.maxbufsiz); call co('K'); end; call crlf; call print$infield(42,'r',31,@('Maximum Memory Per Process = ')); call display$hex$word(sd.mmp); call print$buffer(.(' PARA$')); call crlf; if not(vers) then call print$infield(42,'r',31,@('Number of Virtual Consoles = ')); else call print$infield(42,'r',32,@('Number of Physical Consoles = ')); call display$hex$byte(sd.ncns); call crlf; call print$infield(42,'r',23,@('Number of Printers = ')); call display$hex$byte(sd.nlst); call crlf; call print$infield(42,'r',20,@('Temporary Drive = ')); call co(driv$letter(sd.tempdisk)); call co(':'); call crlf; call print$infield(42,'r',17,@('System Drive = ')); call co(driv$letter(sd.srchdisk)); call co(':'); call crlf; call print$infield(42,'r',21,@('Ticks Per Second = ')); call display$hex$byte(sd.tickspersec); call crlf; call print$infield(42,'r',20,@('Day File Option = ')); if sd.dayfile = 0 then call print$buffer(.('NO $')); else call print$buffer(.('YES$')); call crlf; call print$infield(42,'r',23,@('BDOS Compatability = ')); if sd.cmod <> 0 then call print$buffer(.('YES$')); else call print$buffer(.('NO $')); call crlf; call print$infield(42,'r',20,@('Number of Flags = ')); call display$hex$byte(sd.nflags); call crlf; call print$infield(42,'r',27,@('Free Queue Descriptors = ')); pd$ptr.offset = sd.qul; count = 0; do while pd$ptr.offset <> 0; count = count + 1; pd$ptr.offset = pd.link; end; call display$hex$byte(count); call crlf; call print$infield(42,'r',22,@('Free Queue Buffer = ')); md$ptr.offset = .sd.qmau(0); sat$ptr.segment = md.start; /* start of qbuffer SAT */ sat$ptr.offset = size(sat); /* skip 1st 5 bytes bookeeping*/ qsize = 0; do while sat.start <> 0; /* byte offset for queue buffer*/ if sat.num$allocs = 0 then /* dooes anyone own this piece?*/ qsize = qsize + sat.len; sat$ptr.offset = size(sat) + sat$ptr.offset; /* Get next entry */ end; call display$hex$word(qsize); call print$buffer(.(' BYTES$')); call crlf; call print$infield(42,'r',29,@('Free Process Descriptors = ')); pd$ptr.offset = sd.pul; count = 0; do while pd$ptr.offset <> 0; count = count + 1; pd$ptr.offset = pd.link; end; call display$hex$byte(count); call crlf; call print$infield(42,'r',28,@('Free Memory Descriptors = ')); pd$ptr.offset = sd.mdul; count = 0; do while pd$ptr.offset <> 0; count = count + 1; pd$ptr.offset = pd.link; end; call display$hex$byte(count); call crlf; if not(specified) then call cons$wait; else call terminate; end displaygen;