|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 17664 (0x4500)
Types: TextFile
Names: »topsys«
└─⟦2c55ea56f⟧ Bits:30001844 SW-save af projekt 1000, Alarm-system
└─⟦6b41451d2⟧
└─⟦this⟧ »topsys«
job bbl 7 600 time 6 0 perm mini 100 1 size 130000
(
mode list.yes
platonenv = set bs bblenv
; o opsysout
head 1 cpu
pascal80 codesize.12000 ,
stack.512,
spacing.12000,
codelist.no,
ioenvir
; o c
; convert opsysout
bopsys = set 1 mini
bopsys = move pass6code
if ok.yes
scope project bopsys
finis
)
process opsys(var sem_vector : system_vector);
(**************************************************************************)
(* *)
(* opsys *)
(* *)
(**************************************************************************)
const
ok = 0;
writecode = 2;
readcode = 1;
tomorrow = false;
(* opsys commands *)
notimplemented = 0;
unknowncommand = 1;
linkcommand = 2;
createcommand = 3;
startcommand = 4;
stopcommand = 5;
removecommand = 6;
unlinkcommand = 7;
breakcommand = 8;
excodecommand = 9;
fromcommand = 0;
incommand =11;
listcommand =12;
loadcommand = 0;
lookupcommand =14;
prioritycommand =15;
runcommand =16;
sizecommand =17;
unloadcommand = 0;
(* adam commands *)
adam_link = 1;
adam_create = 2;
adam_start = 3;
adam_stop = 4;
adam_remove = 5;
adam_unlink = 6;
adam_break = 7;
(* linker commands *)
lookupname = 3;
blank = ' ';
asstring = 'as ';
type
adamtype = record
name1 : alfa;
name2 : alfa;
aux1 : integer;
end;
var
rootshadow : shadow;
input : zone;
output : zone;
operator_sem : ^ semaphore;
adam_sem : ^ semaphore;
opsys_sem : semaphore;
bisem : semaphore;
r : reference;
iopool : pool 2 of opbuffer;
m : pool 1 of record
descr : descriptor_segment;
date : coded_date;
time : coded_time
end;
command : alfa;
processname : alfa;
inc_name : alfa;
keyword1 : alfa;
inchannel : integer := 0;
size : integer := 0;
priority : integer := minpriority;
excode : integer := -1;
i : integer;
adamsend : boolean;
break : boolean;
lookahead : boolean;
ch : char;
function asgnptradr(a : addr) : ^shadow; external;
function refshadow(var sh : shadow) : ^shadow;
external;
function usub(a,b : integer) : integer;
external;
function udiv(a,b : integer) : integer;
external;
procedure asgnaddrref(var a : addr; var r : reference);
external;
procedure asgnrefaddr(var r : reference; a : addr);
external;
procedure writestringnl(no : integer);
forward;
procedure exception(code : integer);
var
a : addr;
begin
if not nil(rootshadow) then
begin
asgnaddrref(a,rootshadow.r);
a.base.lockbit := 0;
asgnrefaddr(rootshadow.r,a);
release(rootshadow.r);
end;
trace(code)
end; (* exception *)
procedure list(var z : zone; var name : alfa);
const
procincsize = maxint;
var
foundcandidate : boolean := true;
nilp : ! ^ shadow;
rootsh : ^ shadow;
procedure initroot(root : semtype);
(* initializes stopmsg to rootshadow *)
begin
with rootshadow.r^ do
begin
size := procincsize;
start := own.secret_pointer^(root)^.chain;
end;
rootsh := refshadow(rootshadow);
end; (* initheader *)
procedure findprocinc(var candidate : alfa;from : ^shadow;var res : ^shadow;
level,number : integer);
(*the procedure scans the subtree with root : from, for occourance of
a process incarnation with the name : candidate. the scanning is
performed to the leaves from left to right . level will hold the tree depth
and number will hold the local branch number -number in shadow-chain *)
var
sh : ^shadow;
finis : boolean ;
begin
if not nil(from^) then
begin
level := level+1;
lock from^.r as p : ext_incarnation_descriptor do
begin
if p.incname <> candidate then
begin
sh := asgnptradr(p.shadowchain); (* transform an addr to ^shadow *)
if not nil(sh) then
findprocinc(candidate,sh,res,level,1);
if not foundcandidate then
begin
finis := false;
if not nil(sh) then
repeat
sh := sh^.next;
if not nil(sh^) then
number := number +1;
if not nil(sh) then
begin
findprocinc(candidate,sh,res,level,number);
if foundcandidate then finis := true;
end
else
finis := true;
until finis;
end
end
else
begin
foundcandidate := true;
res := from;
end;
end;
end
end; (*findprocinc*)
procedure listall(res : ^shadow; level,number : integer);
(* the process incarnation names in the subtree from the process
incarnation pointed out by res are written with depth, branchno *)
var
size : integer;
sh : ^shadow;
finis : boolean := false;
begin
if not nil(res^) then
begin
level := level+1;
lock res^.r as p : ext_incarnation_descriptor do
begin
outtext(z,p.incname);
outinteger(z,level,3);
outinteger(z,number,7);
outinteger(z,p.level,7);
if p.incstate = -1 then
outtext(z,' stop #')
else
begin
if (p.chainhead.disp mod 2) = 1 then
outtext(z,' run #')
else
outtext(z,' wait #')
end;
size := udiv(usub(usub(p.maxstack,1),res^.r^.start.disp),2);
if size = maxint then
size := minint
else
size := size + 1;
outinteger(z,size,6);
outtext(z,' #');
outaddr(z,res^.r^.start);
outnl(z);
sh := asgnptradr(p.shadowchain); (* transform an addr to ^shadow *)
if not nil(sh) then
listall(sh,level,number);
if not nil(sh) then
repeat
sh := sh^.next;
if not nil(sh) then
begin
if not nil(sh^) then
number := number+1;
listall(sh,level,number);
end
else
begin
number := 1;
level := level-1;
finis := true;
end
until finis;
end;
end
end; (*listall*)
procedure listfrom(var candidate : alfa);
(* finds candidate and lists the subtree from this point in tree *)
var
res : ^shadow;
xlevel,xnumber : integer;
begin
xlevel := 0;
xnumber := 1;
wait(rootshadow.r,own.secret_pointer^(stopsem)^);
initroot(adamstack);
res := rootsh;
if candidate = "monitor " then initroot(monitorstack)
else if candidate = "timer " then initroot(timerstack)
else if candidate = "allocator " then initroot(allocatorstack)
else if candidate = "linker " then initroot(linkerstack)
else
begin
foundcandidate := false;
findprocinc(candidate,rootsh,res,xlevel,xnumber);
end;
if foundcandidate then
begin
xnumber := 1;
xlevel := 0;
outtext(z,'incarnation ');
outtext(z,'depth #');
outtext(z,'branch #');
outtext(z,'level #');
outtext(z,'state #');
outtext(z,' size #');
outtext(z,' stack#');
outnl(z);
listall(res,xlevel,xnumber);
end
else
writestringnl(3);
release(rootshadow.r)
end; (* listfrom *)
begin
own.shadowchain := nilp; (* det skal der ses paa igen *)
listfrom(name);
end; (* list *)
procedure emptyinput;
begin
repeat
inchar(input,ch)
until ch = nl
end; (* emptyinput *)
procedure getalfa(var name : alfa);
begin
name := blank;
inname(input,name)
end; (* getalfa *)
function search(var name : alfa) : integer;
const
max = 88;
type
r = record
llink : byte;
rlink : byte;
key : char;
action : byte
end;
tabletype = array(1..max) of r;
const
table = tabletype(
r(27, 2,"b",breakcommand ), (* 1 *)
r(32, 3,"c",createcommand ), (* 2 *)
r(38, 4,"e",excodecommand ), (* 3 *)
r(44, 5,"f",fromcommand ), (* 4 *)
r(48, 6,"i",incommand ), (* 5 *)
r( 7,13,"l",unknowncommand ), (* 6 *)
r( 8,10,"i",unknowncommand ), (* 7 *)
r(50, 9,"n",linkcommand ), (* 8 *)
r(52, 0,"s",listcommand ), (* 9 *)
r(11, 0,"o",unknowncommand ), (* 10 *)
r(54,12,"a",loadcommand ), (* 11 *)
r(56, 0,"o",lookupcommand ), (* 12 *)
r(79,14,"p",prioritycommand ), (* 13 *)
r(15,17,"r",unknowncommand ), (* 14 *)
r(60,16,"e",removecommand ), (* 15 *)
r(65, 0,"u",runcommand ), (* 16 *)
r(18,22,"s",unknowncommand ), (* 17 *)
r(67,19,"i",sizecommand ), (* 18 *)
r(20, 0,"t",unknowncommand ), (* 19 *)
r(70,21,"a",startcommand ), (* 20 *)
r(73, 0,"o",stopcommand ), (* 21 *)
r(23, 0,"u",unknowncommand ), (* 22 *)
r(24, 0,"n",unknowncommand ), (* 23 *)
r(25, 0,"l",unknowncommand ), (* 24 *)
r(87,26,"i",unlinkcommand ), (* 25 *)
r(88, 0,"o",unloadcommand ), (* 26 *)
r(28, 0,"r",breakcommand ), (* 27 *)
r(29, 0,"e",breakcommand ), (* 28 *)
r(30, 0,"a",breakcommand ), (* 29 *)
r(31, 0,"k",breakcommand ), (* 30 *)
r( 0, 0, sp,breakcommand ), (* 31 *)
r(33, 0,"r",createcommand ), (* 32 *)
r(34, 0,"e",createcommand ), (* 33 *)
r(35, 0,"a",createcommand ), (* 34 *)
r(36, 0,"t",createcommand ), (* 35 *)
r(37, 0,"e",createcommand ), (* 36 *)
r( 0, 0, sp,createcommand ), (* 37 *)
r(39, 0,"x",excodecommand ), (* 38 *)
r(40, 0,"c",excodecommand ), (* 39 *)
r(41, 0,"o",excodecommand ), (* 40 *)
r(42, 0,"d",excodecommand ), (* 41 *)
r(43, 0,"e",excodecommand ), (* 42 *)
r( 0, 0, sp,excodecommand ), (* 43 *)
r(45, 0,"r",fromcommand ), (* 44 *)
r(46, 0,"o",fromcommand ), (* 45 *)
r(47, 0,"m",fromcommand ), (* 46 *)
r( 0, 0, sp,fromcommand ), (* 47 *)
r(49, 0,"n",incommand ), (* 48 *)
r( 0, 0, sp,incommand ), (* 49 *)
r(51, 0,"k",linkcommand ), (* 50 *)
r( 0, 0, sp,linkcommand ), (* 51 *)
r(53, 0,"t",listcommand ), (* 52 *)
r( 0, 0, sp,listcommand ), (* 53 *)
r(55, 0,"d",loadcommand ), (* 54 *)
r( 0, 0, sp,loadcommand ), (* 55 *)
r(57, 0,"k",lookupcommand ), (* 56 *)
r(58, 0,"u",lookupcommand ), (* 57 *)
r(59, 0,"p",lookupcommand ), (* 58 *)
r( 0, 0, sp,lookupcommand ), (* 59 *)
r(61, 0,"m",removecommand ), (* 60 *)
r(62, 0,"o",removecommand ), (* 61 *)
r(63, 0,"v",removecommand ), (* 62 *)
r(64, 0,"e",removecommand ), (* 63 *)
r( 0, 0, sp,removecommand ), (* 64 *)
r(66, 0,"n",runcommand ), (* 65 *)
r( 0, 0, sp,runcommand ), (* 66 *)
r(68, 0,"z",sizecommand ), (* 67 *)
r(69, 0,"e",sizecommand ), (* 68 *)
r( 0, 0, sp,sizecommand ), (* 69 *)
r(71, 0,"r",startcommand ), (* 70 *)
r(72, 0,"t",startcommand ), (* 71 *)
r( 0, 0, sp,startcommand ), (* 72 *)
r(74, 0,"p",stopcommand ), (* 73 *)
r( 0, 0, sp,stopcommand ), (* 74 *)
r(76, 0,"k",unlinkcommand ), (* 75 *)
r( 0, 0, sp,unlinkcommand ), (* 76 *)
r(78, 0,"d",unloadcommand ), (* 77 *)
r( 0, 0, sp,unloadcommand ), (* 78 *)
r(80, 0,"r",prioritycommand ), (* 79 *)
r(81, 0,"i",prioritycommand ), (* 80 *)
r(82, 0,"o",prioritycommand ), (* 81 *)
r(83, 0,"r",prioritycommand ), (* 82 *)
r(84, 0,"i",prioritycommand ), (* 83 *)
r(85, 0,"t",prioritycommand ), (* 84 *)
r(86, 0,"y",prioritycommand ), (* 85 *)
r( 0, 0, sp,prioritycommand ), (* 86 *)
r(75, 0,"n",unlinkcommand ), (* 87 *)
r(77, 0,"a",unloadcommand ));(* 88 *)
var
ch : char;
i : integer;
j : integer := 1;
k : integer := 0;
label
exit;
begin
search := unknowncommand;
repeat
k := k + 1;
ch := name(k);
i := j;
j := table(i).llink;
while table(i).key <> ch do
begin
i := table(i).rlink;
if i = 0 then
begin
if ch <> sp then
search := unknowncommand;
goto exit
end;
j := table(i).llink
end;
search := table(i).action
until j = 0;
exit:
end; (* search *)
procedure writestring(no : integer);
const
max_no = 13;
stringlength = 33;
type
stringtype = array(1..stringlength) of char;
tabletype = array(-2..max_no) of stringtype;
const
table = tabletype(
'ready#', (* -2 *)
'*** command not implemented:# ', (* -1 *)
'rc3502 real time pascal# ', (* 0 *)
'*** syntax error:#', (* 1 *)
'*** processname missing# ', (* 2 *)
'*** unknown incarnation# ', (* 3 *)
'*** unknown process# ', (* 4 *)
'*** processname busy# ', (* 5 *)
'*** incarnationname missing# ', (* 6 *)
'*** name in use# ' , (* 7 *)
'*** no free processdeclarations# ', (* 8 *)
'*** process not loaded# ', (* 9 *)
'*** process parameters not equal#', (* 10 *)
'*** size too small or too large# ', (* 11 *)
'*** process not linked# ', (* 12 *)
'*** unknown program#' );(* 13 *)
var
i : integer := 1;
begin
while table(no,i) <> "#" do
begin
outchar(output,table(no,i));
i := i + 1
end;
end; (* writestring *)
procedure writestringnl(no : integer);
begin
writestring(no);
outnl(output)
end; (* writestringnl *)
procedure error(no : integer);
begin
writestring(no);
emptyinput;
break := true
end; (* error *)
procedure errornl(no : integer);
begin
error(no);
outnl(output)
end; (* errornl *)
procedure outtextnl(var a : alfa);
begin
outtext(output,a);
outnl(output)
end; (* outtextnl *)
procedure adamerror(no : integer);
type
tabletype = packed array(1..16) of 0..15;
const
table = tabletype(?,7,8,9,10,7,12,11,3,3,3,4,5,3,1,?);
begin
errornl(table(no))
end; (* adamerror *)
function send_adam(fnc , a1 : integer) : integer;
begin
r^.u1 := fnc;
lock r as p : adamtype do
with p do
begin
name1 := processname;
name2 := inc_name;
aux1 := a1
end;
signal(r,sem_vector(adamsem)^);
wait(r,bisem);
send_adam := r^.u2;
end;
procedure adamcommand(var name : alfa; command,a1,errorcode : integer);
var
i : integer;
begin
getalfa(name);
if name <> blank then
begin
i := send_adam(command,a1);
if i <> ok then
adamerror(i)
end
else
errornl(errorcode)
end; (* adamcommand *)
(************************************************************************)
(* *)
(* opsys main program *)
(* *)
(************************************************************************)
begin
setpriority(1);
operator_sem := sem_vector(operatorsem);
openopzone(output,operator_sem,ref(output.free),
1,iopool,writecode,0,0,0);
openopzone(input,operator_sem,ref(opsys_sem),
1,iopool,readcode,0,0,0);
opin(input);
alloc(r,m,bisem);
r^.u1 := lookupname;
lock r as programname : alfa do
programname := own.processref^.name;
signal(r,own.secret_pointer^(linkersem)^);
wait(r,bisem);
lock r as d : record
descr : descriptor_segment;
date : coded_date;
end do
begin
writestring(0); (* inittext *)
outdate(output,d.date);
outnl(output)
end;
repeat
<*
writestringnl(-2); (* ready *)
outend(output);
*>
opwait(input,iopool);
break := false;
lookahead := false;
repeat
if lookahead then
begin
command := keyword1;
lookahead := false
end
else
getalfa(command);
if input.readstate < 0 then
break := true
else
case search(command) of
notimplemented:
begin
error(-1);
outtextnl(command);
end;
unknowncommand:
begin
error(1);
outtextnl(command);
end;
linkcommand:
adamcommand(processname,adam_link,0,2);
createcommand:
begin
getalfa(inc_name); (* get incarnation name *)
if inc_name <> blank then
begin
getalfa(keyword1); (* get -as- keyword *)
if keyword1 = asstring then
adamcommand(processname,adam_create,size,2)
else
begin
processname := inc_name;
i := send_adam(adam_create,size);
if i <> ok then
adamerror(i);
lookahead := true
end
end
else
errornl(6)
end;
startcommand:
adamcommand(inc_name,adam_start,priority,6);
stopcommand:
adamcommand(inc_name,adam_stop,0,6);
removecommand:
adamcommand(inc_name,adam_remove,0,6);
unlinkcommand:
adamcommand(processname,adam_unlink,0,2);
breakcommand:
adamcommand(inc_name,adam_break,excode,6);
excodecommand:
ininteger(input,excode);
incommand:
ininteger(input,inchannel);
listcommand:
begin
getalfa(inc_name);
if inc_name = blank then
inc_name := 'adam';
repeat
list(output,inc_name);
getalfa(inc_name)
until input.readstate < 0
end;
lookupcommand:
begin
lock r as p : alfa do
getalfa(p);
repeat
r^.u1 := lookupname;
signal(r,own.secret_pointer^(linkersem)^);
wait(r,bisem);
if r^.u2 <> ok then
writestringnl(13)
else
lock r as d : record
descr : descriptor_segment;
date : coded_date;
time : coded_time
end do
begin
with d.descr do
begin
case kind of
1: outtext(output,'PROCESS ');
2: outtext(output,'PROCEDURE ');
3: outtext(output,'FUNCTION ')
end;
outtext(output,name);
outdate(output,d.date);
outchar(output,sp);
outtime(output,d.time);
outinteger(output,no_of_pages,3);
outinteger(output,pagesize,6);
outinteger(output,last_page_length,6);
outinteger(output,default_appetite,6);
outinteger(output,no_of_params,3);
end;
outnl(output);
end;
lock r as p : alfa do
getalfa(p)
until input.readstate < 0;
end;
prioritycommand:
ininteger(input,priority);
runcommand:
begin
adamsend := false;
getalfa(inc_name);
if inc_name <> blank then
begin
getalfa(keyword1); (* as *)
if keyword1 = asstring then
begin
getalfa(processname);
if processname <> blank then
adamsend := true
else
errornl(2)
end
else
begin
adamsend := true;
processname := inc_name;
lookahead := true
end
end
else
errornl(6);
if adamsend then
begin
i := send_adam(adam_link,0);
if i > 2 then
adamerror(i)
else
begin
i := send_adam(adam_create,size);
if (i = ok) or (i = 6) then
begin
i := send_adam(adam_start,priority);
if i <> ok then
adamerror(i)
end
else
adamerror(i)
end
end
end;
sizecommand:
ininteger(input,size)
end
until break;
opin(input);
until tomorrow
end (* opsys *)
.
▶EOF◀