|
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: 86016 (0x15000)
Types: TextFile
Names: »ttramos«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »ttramos«
begin
<* variables for claiming (accumulating) basic entities *>
integer maxsem, maxsemch, maxop, maxcoru, maxmessext, maxprocext, maxnettoop;
<* fields defining current position in pools af basic entities
during initialization *>
integer array field firstsem, firstsim, firstcoru, firstop, optop;
<* variables used as pointers to 'current object' (work variables) *>
integer messext, procext, timeinterval, testbuffering;
integer array field timermessage, coru, sem, op, receiver, currevent,
baseevent, prevevent;
<* variables defining the size of basic entities (descriptors) *>
integer corusize, semsize, simsize, opheadsize;
integer array clockmess(1:2);
real array clock(1:3);
boolean eventqueueempty;
message trim variables;
algol list.on;
integer no_of_terminals,max_children,cur_children,
child_base_address,childrencreated,termdisconnect,
oscommunication,osparentmess,
length_user_cat_entry,
length_user_cat_entry0,size_user_cat,
user_cat_users,
con_desc_size,
no_of_drums,no_of_discs,no_of_bs,
core_block_size,no_of_core_blocks,
first_user_core,
reader,punch,console1,console2,firstmt,lastmt,firstterminal,
lastterminal,lastdevice,
sysconpda,
ownbuf,ownarea,owninternal,
freebuf,freearea,freeinternal,
user_cat_lower,user_cat_upper,
cat_sem,z_sem;
integer field base_ref;
integer array field cat_base_ref,std_base_ref,max_base_ref,
core_address_ref,own_ref,
first_bs_ref,size_bs_ref;
long field run_time_ref,start_time_ref;
integer field buf_area_ref,int_func_ref,parent_ref;
boolean field state_ref;
integer bit_0,bit_batch,bit_abs_size,bit_std_base,
bit_evening,bit_maxclaim,bit_auto,bit_waiting,
bit_c1,bit_priv,tw_mask;
boolean bit_mess,bit_answer,bit_wait,
bit_run ,bit_stop ,bit_start,
bit_proc,bit_not_run,mon_list,mon_change;
integer std_buf,std_area,std_int,std_func,std_size,
std_temp_entries,
std_entries,std_segm_disc,std_segm_disc1,
std_entry_disc,std_entry_disc1;
integer std_max_buf,std_max_area,std_max_int,std_max_size,
std_max_entries,std_max_segm_disc,std_max_segm_disc1,
std_max_entry_disc,std_max_entry_disc1,
own_entries,own_entry_disc,own_segm_disc,
own_entry_disc1,own_segm_disc1;
long array drum_name,std_disc_name,std_disc1_name,
user_cat_name,own_drum,own_disc,own_disc1,
std_program,
own_name,name1,name(1:3);
long array field laf;
integer array field iaf;
real array field raf;
integer i,j,k;
integer field con_access,con_prio_and_commands,
con_first_address,con_top_address,con_buf_and_area,
con_job_id,
con_int_and_func,con_mode,
con_lower_max,con_upper_max,con_lower_std,con_upper_std,
con_size,con_lower_user,con_upper_user,con_projno,
con_usercat_no,con_job_state,
con_term_pda,
con_cur_child,con_cur_child_pda,
con_term_no,con_ref,con_proc_in,con_proc_out,
con_job;
integer array field cur_con_desc,con_first_bs,fi;
long array field con_proc_name,con_program,
con_des_term,
con_in_name,con_out_name,con_term_name,con_job_name;
integer maxpmess,maxmess;
boolean array testop(1:12);
long array sysconsole,logconsole,monitorconsole(1:3);
integer array tail(1:10);
long array field doc;
array field f;
boolean lock;
algol list.off;
algol copy.tmonpr;
message error messages: trim variable;
integer size_error_message;
message batch queue: trim variables and fields;
algol list.on;
integer qdescsize,qdes,b_max_jobs,b_curjob,
b_child_first,b_child_last,
b_max_time,
b_max_time_day, b_max_size_day,
b_max_time_night,b_max_size_night,
b_day_to_night, b_night_to_day,
b_upd_time,b_interval,b_time_slice,b_std_time,
b_max_children,b_cur_children,b_job_number,
b_run_children,b_stop_begin,b_stop_end,
swop_segm,
b_max_prio_day;
real b_time_fac,b_job_fac;
integer field q_jobmask,
q_job_no,q_job_state,q_job_seq,q_max_time,
q_start_time,
q_remove_job_file,q_lref;
long array field q_job_name,q_printer,q_wrk_o,
d_job_name;
integer field q0_max_time_day,q0_max_size_day,
q0_max_time_night,q0_max_size_night,
q0_day_to_night,q0_night_to_day,
q0_upd_time;
long array qname,swop,swopdoc(1:3);
algol list.off;
message primary input: global definitions;
integer array field l_line_buf;
integer field l_next,l_type;
long array field l_procname,l_jobname,l_outname,l_printer,l_last;
maxsem:= maxsemch:= maxop:= maxcoru:= maxnettoop:= 0;
maxmessext:= maxprocext:= 1;
corusize:= 20;
simsize:= 6;
semsize:= 8;
opheadsize:= 8;
testbuffering:= 1;
timeinterval:= 5;
message trimming;
algol list.on;
lock:=true;
bit_0 :=(1 shift 0);
bit_batch :=(1 shift 1);
bit_abs_size:=(1 shift 2);
bit_std_base:=(1 shift 3);
bit_evening :=(1 shift 4);
bit_maxclaim:=(1 shift 5);
bit_auto :=(1 shift 6);
bit_waiting :=(1 shift 7);
bit_c1 :=(1 shift 8);
bit_priv :=(1 shift 9);
twmask:=-1; <*mask for typewriters in call of open*>
<*bits for process state*>
bit_mess :=false add (1 shift 0);
bit_answer :=false add (1 shift 1);
bit_wait :=false add (1 shift 2);
bit_run :=false add (1 shift 3);
bit_stop :=false add (1 shift 4);
bit_start :=false add (1 shift 5);
bit_proc :=false add (1 shift 6);
bit_not_run:=false add (1 shift 7);
state_ref :=12; <*process state*>
buf_area_ref:=28;
int_func_ref:=30;
parent_ref:=52;
std_base_ref:=76;
max_base_ref:=72;
cat_base_ref:=68;
core_address_ref:=22;
start_time_ref:=60+2;
run_time_ref:=56+2;
base_ref:=100; <*base register*>
firstbs_ref:=86;
size_bs_ref:=18;
i:=0;
i:=con_access:=i+2;
i:=con_prio_and_commands:=i+2;
i:=con_proc_name:=i;
i:=con_first_address:=i+2+8;
i:=con_top_address:=i+2;
i:=con_buf_and_area:=i+2;
i:=con_int_and_func:=i+2;
i:=con_mode:=i+2;
i:=con_lower_max:=i+2;
i:=con_upper_max:=i+2;
i:=con_lower_std:=i+2;
i:=con_upper_std:=i+2;
i:=con_size:=i+2;
i:=con_program:=i;
i:=con_lower_user:=i+2+8;
i:=con_upper_user:=i+2;
i:=con_projno:=i+2;
i:=con_user_cat_no:=i+2;
i:=con_in_name:=i;
i:=con_out_name:=i+8;
i:=con_term_name:=i+8;
i:=con_jobstate:=i+10;
i:=con_job_id:=i+2;
con_first_bs:=con_desc_size:=i+10;
doc:=2;
fi:=f:=0; readsfp(<:c:>,logconsole.f,<:c:>);
for i:=1 step 1 until 12 do testop(i):=false;
connectlso;
for i:=1 step 1 until 11 do
begin
if testop(i) then write(out,"nl",1,<:*test :>,case i of (
<:init:>,<:create:>,<:verify:>,<:usercat:>,
<:communication:>,<:error:>,<:batch:>,<:submit:>,
<:job:>,<:primary in:>,<:queue selection:>));
end;
outendcur(10);
readsfp(<:cat:>,usercatname.f,<:osusercat:>);
std_program(1):=long <:fp:>;
std_program(2):=
sysconsole(2):=logconsole(2):=monitorconsole(2):=
drumname(2):=stddiscname(2):=stddisc1name(2):=0;
curchildren:=0;
maxmess:=5;
maxpmess:=5;
console1:=2;
ownbuf:=2;
ownarea:=2;
owninternal:=1;
child_base_address:=128*1024;
algol list.on copy.tramoption;
ownbuf:=ownbuf+noofterminals;
readifp(<:children:>,maxchildren,maxchildren);
readifp(<:blocks:>,noofcoreblocks,noofcoreblocks);
if maxchildren<noofcoreblocks then maxchildren:=noofcoreblocks;
readifp(<:size:>,coreblocksize,coreblocksize);
readifp(<:terminals:>,no_of_terminals,no_of_terminals);
i:=lookupentry(logconsole,tail);
if i<>0 then alarm("nl",1,logconsole,<: does not exist:>,i);
for i:=1,2 do logconsole(i):=tail.doc(i);
write(out,<:log console is :>,logconsole);
if readsfp(<:monitor:>,name.f,<::>) then
readsfp(<:monitor:>,monitorconsole.f,<::>);
write(out,"nl",1,<:monitor console :>,monitorconsole);
name(1):=0;
set_cat_base(name,usercatlower,usercatupper);
i:=connectcuri(usercatname);
if i<>0 then alarm("*",3,usercatname,<: connect error :>,i);
setposition(in,0,0);
inrec6(in,512);
length_user_cat_entry:=in.fi(2);
length_user_cat_entry0:=in.fi(3);
size_user_cat:=in.fi(4);
user_cat_users:=in.fi(5);
unstackcuri;
no_of_bs:=no_of_drums+no_of_discs;
if no_of_bs*12+14<>lengthusercatentry0 then alarm("nl",1,
<:***number of bs devices inconsistent:>,no_of_bs);
i:=condescsize:=condescsize+size_bs_ref*(no_of_drums+no_of_discs);
i:=con_proc_in:=i+4;
i:=con_proc_out:=i+2;
i:=con_term_pda:=i+2;
i:=con_des_term:=i;
i:=con_job_name:=i+8;
i:=con_cur_child:=i+2+8;
i:=con_cur_child_pda:=i+2;
i:=con_term_no:=i+2;
i:=con_ref:=i+2;
i:=con_job:=i+2;
condescsize:=i;
algol list.off;
message error message: initialize trim;
size_error_message:=200;
message batch queue: initialization;
algol list.on;
d_job_name:=4;
i:=qdescsize:=condescsize;
i:=q_jobno:=i+2;
i:=q_jobmask:=i+2;
i:=q_job_state:=i+2;
i:=q_job_seq:=i+2;
i:=q_max_time:=i+2;
i:=q_start_time:=i+2;
i:=q_remove_job_file:=i+2;
i:=q_lref:=i+2;
i:=q_job_name:=i;
i:=q_printer:=i+8;
i:=q_wrk_o:=i+8;
i:=qdescsize:=i+8;
<*global information*>
i:=q0_max_time_day:=con_desc_size+2;
i:=q0_max_size_day:=i+2;
i:=q0_max_time_night:=i+2;
i:=q0_max_size_night:=i+2;
i:=q0_night_to_day:=i+2;
i:=q0_day_to_night:=i+2;
i:=q0_upd_time:=i+2;
qname(1):=long <:bqueu:> add 'e';
qname(2):=0;
b_max_time_day:=20*60; <*sec*>
b_max_time_night:=8*60*60;
b_max_size_day:=512*coreblocksize;
b_cur_job:=0;
b_maxjobs:=250;
b_max_children:=1;
b_std_time:=5*60;
b_time_slice:=30;
b_interval:=5;
swop(1):=long <:bswop:>; swop(2):=0;
for i:=1,2 do swopdoc(i):=owndisc(i);
b_time_fac:=0.5;
b_job_fac :=1.0;
algol copy.batchtrim;
readifp(<:btimeslice:>,b_time_slice,b_time_slice);
b_max_prio_day:=2*b_max_time_day;
readifp(<:bprio:>,b_max_prio_day,b_max_prio_day);
readrfp(<:btimefac:>,btimefac,btimefac);
readrfp(<:bjobfac:>,bjobfac,bjobfac);
readifp(<:bchildren:>,bmaxchildren,bmaxchildren);
readifp(<:bjobs:>,bmaxjobs,bmaxjobs);
readifp(<:bstdtime:>,bstdtime,bstdtime);
readifp(<:time:>,b_max_time_day,b_max_time_day);
laf:=2;
swopsegm:=bmaxchildren*bmaxsizenight//512+1;
b_curchildren:=0;
qdes:=b_maxchildren+1;
b_job_number:=0;
if readifp(<:bsize:>,bmaxsizeday,bmaxsizeday) then
bmaxsizeday:=bmaxsizeday*1024; <*halfwords*>
algol list.off;
message primary input: initialization of globals;
i:=l_next:=2;
i:=l_type:=i+2;
i:=l_procname:=i;
i:=l_jobname:=i+8;
i:=l_outname:=i+8;
i:=l_printer:=i+8;
i:=l_last:=i+8;
message tramos trim: claiming basic;
maxsem:=maxsem+3+maxchildren;
message readcommand: claiming basic;
maxcoru:=maxcoru+noofterminals+maxmess;
maxsem:=maxsem+no_of_terminals;
maxsemch:=maxsemch+1;
maxop:=maxop+noofterminals+1;
maxnettoop:=maxnettoop+8*(noofterminals+1);
maxprocext:=maxprocext+1;
maxmessext:=maxmessext+noofterminals;
message parent message: claiming basic;
maxcoru:=maxcoru+1;
maxsemch:=maxsemch+1;
maxop:=maxop+maxpmess;
maxnettoop:=maxnettoop+8*maxpmess;
message batch que: claiming basic;
maxcoru:=maxcoru+4;
maxsemch:=maxsemch+2;
maxop:=maxop+qdes+b_max_jobs+4;
maxnettoop:=maxnettoop+12*qdes+6*(bmaxjobs+4);
maxsem:=maxsem+qdes+1;
maxmessext:=maxmessext+1;
message primary input: claiming basic;
maxcoru:=maxcoru+1;
maxprocext:=maxprocext+1;
begin
<* work variables - primarily used during initialization *>
integer array field simref, semref, coruref, opref;
integer proccount, corucount, messcount, cmi, cmj;
integer array zoneia(1:20);
<* field variables describing the format of basic entities *>
integer field
<* chain head *>
next, prev,
<* simple semaphore *>
simvalue, simcoru,
<* chained semaphore *>
semop, semcoru,
<* coroutine *>
coruop, corutimerchain, corutimer, corupriority, coruident,
<* operation head *>
opnext, opsize;
boolean field
corutypeset, corutestmask, optype;
real starttime;
long corustate;
<* field variables used as queue identifiers (addresses) *>
integer array field current, readyqueue, idlequeue, timerqueue;
<* extensions (message- and process- extensions) *>
integer array messref, messcode, messop (1:maxmessext);
integer array procref, proccode, procop (1:maxprocext);
<* core array used for accessing the core using addresses as field
variables (as delivered by the monitor functions)
- descriptor array 'd' in which all basic entities are allocated
(except for extensions) *>
integer array core (1:1), d (1:(4 <* readyqueue *> +
4 <* idlequeue *> +
4 <* timerqueue *> +
maxcoru * corusize +
maxsem * simsize +
maxsemch * semsize +
maxop * opheadsize +
maxnettoop)/2);
<*************** initialization procedures ***************>
procedure initchain (chainref);
value chainref;
integer array field chainref;
begin
integer array field cref;
cref:= chainref;
d.cref.next:= d.cref.prev:= cref;
end;
<***** nextsem *****
this procedure allocates and initializes the next simple semaphore in the
pool of claimed semaphores.
the procedure returns the identification (the address) of the semaphore to
be used when calling 'signal', 'wait' and 'inspect'. *>
integer procedure nextsem;
begin
nextsem:= simref;
if simref >= firstsem then initerror(1, true);
initchain(simref + simcoru);
d.simref.simvalue:= 0;
simref:= simref + simsize;
end;
<***** nextsemch *****
this procedure allocates and initializes the next simple semaphore in the
pool of claimed semaphores.
the procedure returns the identification (the address) of the semaphore to
be used when calling 'signalch', 'waitch' and 'inspectch'. *>
integer procedure nextsemch;
begin
nextsemch:= semref;
if semref >= firstop-4 then initerror(2, true);
initchain(semref + semcoru);
initchain(semref + semop);
semref:= semref + semsize;
end;
<***** nextcoru *****
this procedure initializes the next coroutine description in the pool of
claimed coroutine descriptions.
at initialization is defined the priority (an integer value), an identi-
fication (an integer value 0..8000) and a test pattern (a boolean). *>
integer procedure nextcoru(ident, priority, testmask);
value ident, priority, testmask;
integer ident, priority;
boolean testmask;
begin
corucount:= corucount + 1;
if corucount > maxcoru then initerror(3, true);
nextcoru:= corucount;
initchain(coruref + next);
initchain(coruref + corutimerchain);
initchain(coruref + coruop);
d.coruref.corupriority:= priority;
d.coruref.coruident:= ident * 1000 + corucount;
d.coruref.corutypeset:= false;
d.coruref.corutimer:= 0;
d.coruref.corutestmask:= testmask;
linkprio(coruref, readyqueue);
current:= coruref;
coruref:= coruref + corusize;
end;
<***** nextop *****
this procedure initializes the next operation in the pool of claimed ope-
rations (heads and buffers).
the head is allocated and immediately following the head is allocated 'size'
halfwords forming the operation buffer.
the procedure returns an identification of the operation (an address) and
in case this address is held in a field variable 'op', the buffer area may
be accessed as: d.op(1), d.op(2), d.op(3) ... *>
integer procedure nextop (size);
value size;
integer size;
begin
nextop:= opref;
if opref >= optop then initerror(4, true);
initchain(opref + next);
d.opref.opsize:= size;
opref:= opref + size + opheadsize;
end;
<***** nextprocext *****
this procedure initializes the next process extension in the series of
claimed process extensions.
the process description address is put into the process extension and the
state of the extension is initialized to be closed. *>
integer procedure nextprocext (processref);
value processref;
integer processref;
begin
proccount:= proccount + 1;
if proccount >= maxprocext then initerror(5, true);
nextprocext:= proccount;
procref(proccount):= processref;
proccode(proccount):= 1 shift 12;
end;
<***** initerror *****
this procedure is activated in case the initialized set of resources does
not match the claimed set.
in case more resources are claimed than used, a warning is written,
in case too few resources are claimed, an error message is written and
the execution is terminated. *>
procedure initerror (resource, exceeded);
value resource, exceeded;
integer resource; boolean exceeded;
begin
write(out, false add 10, 1,
if exceeded then <:more :> else <:less :>,
case resource of (
<:simple semaphores:>,
<:chained semaphores:>,
<:coroutines:>,
<:operations:>,
<:process extensions:>),
<: initialized than claimed:>,
false add 10, 1);
if exceeded then goto dump;
end;
<***** stackclaim *****
this procedure is used by a coroutine from its first activation to it
arrives its first waiting point. the procedure is used to claim an addi-
tional amount of stack space. this must be done because the maximum
stack space for a coroutine is set to be the max amount used during its
very first activation. *>
procedure stackclaim (size);
value size; integer size;
begin
boolean array stackspace (1:size);
end;
message tramos trim global variables and procedures;
algol list.on;
integer logsem;
boolean free,stopsystem;
zone log(128,1,noerror),cat(768,2,stderror),z(128,1,stderror);
long array basestack(1:25);
long array field basep,maxbasep;
integer array con_pda_table(1:no_of_terminals),
con_desc(1:no_of_terminals*con_desc_size//2),
chartable(0:255),user_core(1:256*coreblocksize*noofcoreblocks),
usercatbs(1:6*no_of_bs),ownbs,freebs(1:8*no_of_bs),
perm_bs_claimed(1:usercatusers+10,1:noofbs,1:4),
<*+10 to allow some updating of the usercatalog
while running*>
includelist(0:lastdevice),
coretable(1:no_of_core_blocks+1,1:2),
childtable(1:(maxchildren+1)*20);
boolean array bs_exist(1:no_of_bs+1);
<*use of childtable
1: childpda
2: destermpda
3: state (1 created, 2 running, 3 stopped, 4 breaked, 5 swopped
4: ref to descriptor
5: jobname
6: -
7: -
8: -
9: batch or online (0=online, 1=batch)
10: first address
11: last address
12: job number
13: segment number swop
14: segment number batch queue
15: buffer ref finis or break
16: childno
17: usercatno
18: process description in
20: access semaphore
19: process description out
*>
integer field ct_child_pda, ct_term_pda, ct_state,
ct_ref, ct_batch, ct_first, ct_last,
ct_jobno, ct_segm_swop, ct_segm_queue,
ct_bufref,ct_childno,ct_usercatno,
ct_procin,ct_procout,ct_sem;
integer state_created,state_running,state_stopped,
state_breaked,state_swopped,state_removed,
ct_size;
long array field ct_job_name;
procedure set_base(lower,upper);
value lower,upper; integer lower,upper;
begin
integer res;
long array name(1:2);
integer array field lu;
name(1):=0;
lu:=0;
if basep>=maxbasep then alarm("nl",1,<:base pointer:>) else
begin
res:=set_cat_base(name,lower,upper);
if res>0 then alarm("nl",1,<:base interval:>,res,lower,upper,basep) else
begin
basestack.basep.lu(1):=lower;
basestack.basep.lu(2):=upper;
basep:=basep+4;
end set cat base;
end no stack over flow;
end set base;
procedure resetbase;
begin
integer res;
long array name(1:2);
integer array field lu;
name(1):=0;
lu:=0;
if basep=0 then set_base_std else
begin
basep:=basep-4;
res:=set_cat_base(name,basestack.basep.lu(1),basestack.basep.lu(2));
if res<>0 then alarm("nl",1,<:reset base :>,res,basep);
end basep>0;
end reset_base;
procedure set_base_std;
begin
setbase(core.ownref.stdbaseref(1),core.ownref.stdbaseref(2));
end;
procedure set_base_user_cat;
begin
setbase(usercatlower,usercatupper);
end;
procedure set_own_bs(doc,claim,owndoc,ownsegm,ownentry);
value ownsegm,ownentry; integer ownsegm,ownentry;
long array doc,owndoc;
integer array claim;
if doc(1)<>owndoc(1) or doc(2)<>owndoc(2) then
begin
integer i; for i:=1 step 1 until 8 do claim(i):=0;
end else
begin
integer i;
for i:=2 step 2 until 8 do
begin
claim(i-1):=ownentry;
claim(i ):=ownsegm;
end
end setownbs;
integer procedure find_term(pda);
value pda; integer pda;
if pda=0 then findterm:=-1 else
begin
integer i,j;
findterm:=i:=0;
j:=no_of_terminals+1;
for i:=i+1 while i<=no_of_terminals and j=no_of_terminals+1 do
if con_pda_table(i)=pda then j:=findterm:=i;
cur_con_desc:=(j-1)*con_desc_size;
end findterm;
integer procedure next_free_term(pda);
value pda; integer pda;
if pda=0 then next_free_term:=-1 else
begin
integer i,j,k;
long array field name;
i:=next_free_term:=0;
j:=no_of_terminals+1;
for i:=i+1 while i<=no_of_terminals and j=no_of_terminals+1 do
if con_pda_table(i)=0 or con_pda_table(i)=pda then
begin
j:=nextfreeterm:=i;
con_pda_table(j):=pda;
cur_con_desc:=(j-1)*con_desc_size;
condesc.curcondesc.contermpda:=pda;
name:=pda+2;
for k:=1,2 do condesc.curcondesc.condesterm(k):=core.name(k);
condesc.curcondesc.contermno:=i;
end found;
end next free term;
procedure noerror(z,s,b);
zone z; integer s,b;
begin
comment no action;
end;
procedure writelog(t1,i,t2);
string t1,t2; integer i;
begin
wait(logsem);
write(log,t1,i,"sp",1,t2,"nl",1);
setposition(log,0,0);
signal(logsem);
end;
algol list.off;
message readcommand global variables and procedures;
algol list.on;
integer ownpda,tpspda;
integer messaddress,attline;
boolean att,verify;
zone array c_buf(no_of_terminals,17,1,no_error);
algol copy.tchildpr;
algol copy.treaduscat;
algol copy.treadclist;
algol copy.tnextparam;
procedure readcommand(cno);
value cno; integer cno;
begin
integer rem,pda,termno,el;
integer array field cur;
boolean stop,waitc;
integer array field attref;
stackclaim(850);
stop:=false;
repeat
waitc:=waitch(attline,attref,att or stopsystem,0);
if (stopsystem and waitc) extract 12 =0 then
begin
pda:=d.attref(1);
termno:=findterm(pda);
if termno=0 then termno:=nextfreeterm(pda);
cur:=curcondesc;
inspect(condesc.cur.conaccess,el);
wait(condesc.cur.conaccess);
readcommandlist(c_buf(termno),condesc.curcondesc,false);
signal(condesc.cur.conaccess);
signalch(attline,attref,free);
end else stop:=true;
until stop;
writelog(<:readcommand:>,cno,<:stopped:>);
end readcommand;
procedure receivemess(no);
value no; integer no;
begin
boolean stop;
integer array M,A(1:8);
integer array field taddress;
integer array field bufref,attref,pmessref;
stackclaim(350);
stop:=false;
repeat
cwaitmessage(messaddress,M,bufref,0);
taddress:=core.bufref(4);
if taddress<0 then sendanswer(1,bufref,A) else
if core.taddress(1)=0 then
begin
<*parent message*>
waitch(pmessline,pmessref,free,0);
d.pmessref(1):=taddress;
d.pmessref(2):=bufref;
signalch(pmessline,pmessref,pmess);
osparentmess:=osparentmess+1;
end else
begin
sendanswer(1,bufref,A);
waitch(attline,attref,free,0);
d.attref(1):=taddress;
signalch(attline,attref,att or (stop and stopsystem));
oscommunication:=oscommunication+1;
end terminal;
until stop;
writelog(<:receivemess:>,0,<:finis:>);
end receivemess;
algol list.off;
message parent message global variables and procedures;
algol list.on;
boolean pmess;
integer pmessline;
algol list.on copy.treadjob;
procedure receive_parent_message;
begin
integer i,j,res,cbn,op,mode,word,job;
integer array M,A(1:8);
integer array field bufref,parentref,child_pda,cur,fi,
bufd,reg,ct,bref;
long array field nf;
integer field interrupt_address;
long array name,text(1:3);
boolean pause,batch;
zone pz(17,1,noerror);
stackclaim(750);
interruptaddress:=38;
for i:=1 step 1 until 8 do A(i):=0;
fi:=0;
repeat
waitch(pmessline,parentref,pmess,0);
bufref:=d.parentref(2);
child_pda:=core.bufref(4);
if childpda<0 then send_answer(1,bufref,A) else
begin
cbn:=0;
ct:=-ct_size;
repeat cbn:=cbn+1;
ct:=ct+ct_size;
until cbn>maxchildren or childpda=childtable.ct.ct_childpda;
if cbn<=maxchildren then wait(childtable.ct.ct_sem);
if cbn>maxchildren or childtable.ct.ct_childpda<>childpda then
sendanswer(2,bufref,A) else
begin
<*it was a child*>
op:=core.bufref(5) shift (-12) extract 12;
mode:=core.bufref(5) extract 12;
pause:=mode extract 1=1;
if op mod 2=1 or op>42 then sendanswer(3,bufref,A) else
if op=0 then sendanswer(1,bufref,A) else
begin
nf:=childpda+2;
for i:=1,2 do name(i):=core.nf(i);
cur:=childtable.ct.ct_ref; <*console description*>
batch:=childtable.ct.ct_batch>0;
if op//2<3 then childtable.ct.ct_bufref:=bufref;
if batch then
begin
open(pz,8,q.cur.condesterm,tw_mask);
if pause then
begin
waitch(bmessline,bref,free,0);
d.bref(1):=1; <*signal to clock driver*>
d.bref(2):=-1; <*stop*>
d.bref(3):=ct;
signalch(bmessline,bref,cmess);
end pause;
end else
begin
wait(condesc.cur.conaccess);
if condesc.cur.concurchildpda<>childpda then
begin
for i:=1,2 do condesc.cur.conprocname(i):=name(i);
condesc.cur.concurchildpda:=childpda;
condesc.cur.concurchild:=childtable.ct.ct_childno;
end;
open(pz,8,condesc.cur.condesterm,tw_mask);
if pause then res:=stopchild(condesc.cur);
end;
write(pz,"nl",1,if pause then <:pause:> else <:message:>,
"sp",1,name,"sp",1);
op:=op//2;
mode:=mode shift (-5);
text(2):=0;
bufd:=bufref+10;
for i:=1 step 1 until 7 do
begin
word:=core.bufd(i);
if mode shift (i-7)=1 then
write(pz,word) else
begin
text.fi(1):=word; text.fi(2):=0;
write(pz,text);
if word=0 then write(pz,"sp",1);
end text;
end write buffer content;
if op<3 then childtable.ct.ct_bufref:=bufref;
case op of
begin
begin <*finis*>
if batch then
begin
waitch(bmessline,bref,free,0);
d.bref(1):=1; <*clock*>
d.bref(2):=-5; <*finis*>
d.bref(3):=ct;
signalch(bmessline,bref,cmess);
end batch else
begin
res:=stopchild(condesc.cur);
if res<>0 then disable
write(pz,<:**stop int :>,condesc.cur.conprocname,res);
res:=removechild(condesc.cur,pz);
if res<>0 then write(pz,<:**remove error :>,name,res,
childtable.ct.ct_state);
end online;
end finis;
begin <*break*>
if core.childpda(40+7)>0 and core.childpda(40+7)<18 then
write(pz,core.childpda(40+7),<: ic :>,core.childpda(40+6),
<: w0 :>,core.childpda(41),
<: w1 :>,core.childpda(42),
<: w2 :>,core.childpda(43),
<: w3 :>,core.childpda(44));
if batch then
begin
waitch(bmessline,bref,free,0);
d.bref(1):=1;
d.bref(2):=-4;
d.bref(3):=ct;
signalch(bmessline,bref,cmess);
end else
begin
res:=stopchild(condesc.cur);
childtable.ct.ct_state:=state_breaked;
end;
end break;
begin <*hard error*>
end hard error;
begin <*account*>
end account;
begin <*replace*>
end replace;
begin <*new job*>
read_job_file(ct,bufref,A,pz);
end newjob;
begin <*mount tape*>
end mount;
begin <*print*>
end print;
begin <*mount ring*>
end ring;
begin <*suspend tape*>
end suspend;
begin <*release tape*>
end release;
begin <*load*>
end load;
begin <*change paper*>
end change;
begin <*timer*>
end timer;
begin <*convert*>
end convert;
begin <*mount special*>
end mount special;
begin <*mount kit*>
end kit;
begin <*lock*>
lock:=true;
end lock;
begin <*open*>
lock:=false;
end open;
begin <*remove*>
end remove;
begin <*swop and wait*>
end swop and wait;
end case;
if op>=3 then sendanswer(1,bufref,A);
if -,batch then signal(condesc.cur.conaccess);
close(pz,true);
end legal operation;
end it was a child;
if cbn<=maxchildren then signal(childtable.ct.ctsem);
end childpda>0;
signalch(pmessline,parentref,free);
until false;
end parent message;
algol list.off;
message error message: global variables and procedures,;
algol list.on;
long array error_texts(1:sizeerrormessage);
long array field error_ready,error_syntax,error_not_allowed,
error_no_core,
error_no_buffers,error_no_areas,error_no_internals,
error_process_unknown,error_process_exists,
error_catalog_error,error_area_unknown,
error_area_reserved,error_program_too_big,
error_area_error,error_device_unknown,
error_device_reserved,error_not_implemented,
error_bs_claims_exceeded,error_bs_device_unknown,
error_name_unknown,error_no_entries_in_maincat,
error_illegal_priority,error_program_name_unknown,
error_name_conflict,
error_result_impossible,error_job_file_unknown,
error_job_number_not_found;
procedure init_error_text(e);
long array e;
begin
integer array field p,max_error;
integer i,j;
integer array f(1:sizeerrormessage);
array field t;
long array field lf;
<* an error record lookup like this:
+0 param(1)
+2 param(2)
+4 param(3)
+6 error text
where the value of param indicates:
param(i)=<=0 dummy
1 integer
>1 reference to a text
*>
for i:=1 step 1 until size_error_message do e(i):=0;
j:=1;
i:=t:=f(j):=error_ready:=6; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:ready:>);
i:=t:=f(j):=error_syntax:=12+i; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:***syntax:>);
i:=t:=f(j):=error_not_allowed:=16+i; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:not allowed:>);
i:=t:=f(j):=error_no_core:=16+i; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:no core:>);
i:=t:=f(j):=error_no_buffers:=16+i; j:=j+1; p:=i-6;
e.p(1):=1;e.p(2):=e.p(3):=-1; movestring(e.t,1,<:no buffers:>);
i:=t:=f(j):=error_no_areas:=16+i; j:=j+1; p:=i-6;
e.p(1):=-1;e.p(2):=1;e.p(3):=-1; movestring(e.t,1,<:no areas:>);
i:=t:=f(j):=error_no_internals:=16+i; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=-1;e.p(3):=1; movestring(e.t,1,<:no internals:>);
i:=t:=f(j):=error_process_unknown:=16+i; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:process unknown:>);
i:=t:=f(j):=error_process_exists:=20+i; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:process exists:>);
i:=t:=f(j):=error_catalog_error:=20+i; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:catalog error:>);
i:=t:=f(j):=error_area_unknown:=20+i; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:area unknown:>);
i:=t:=f(j):=error_area_reserved:=16+i; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:area reserved:>);
i:=t:=f(j):=error_program_too_big:=20+i; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:program too big:>);
i:=t:=f(j):=error_area_error:=20+i; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:area error:>);
i:=t:=f(j):=error_device_unknown:=16+i; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:device unknown:>);
i:=t:=f(j):=error_device_reserved:=20+i; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:device reserved:>);
i:=t:=f(j):=error_not_implemented:=20+i; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:not implemented:>);
i:=t:=f(j):=error_bs_claims_exceeded:=20+i; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:bs claims exceded:>);
i:=t:=f(j):=error_bs_device_unknown:=20+i; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:bs device unknown:>);
i:=t:=f(j):=error_name_unknown:=20+i; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:name unknown:>);
i:=t:=f(j):=error_no_entries_in_maincat:=20+i;j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:no entries in main catalog:>);
i:=t:=f(j):=error_illegal_priority:=32+i; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:illegal priority:>);
i:=t:=f(j):=error_program_name_unknown:=20+i; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:progran name unknown:>);
i:=t:=f(j):=error_name_conflict:=i+28; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:name conflict:>);
i:=t:=f(j):=error_result_impossible:=i+24; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:result impossible:>);
i:=t:=f(j):=error_job_file_unknown:=i+20; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:job file unknown:>);
i:=t:=f(j):=error_job_number_not_found:=i+20; j:=j+1; p:=i-6;
e.p(1):=e.p(2):=e.p(3):=-1; movestring(e.t,1,<:job number not found:>);
end init error;
procedure writeerror(z,error,auxerror);
long array field error;
zone z;
integer array auxerror;
begin
long array field lf;
integer array field p;
p:=error-6;
write(z,errortexts.error);
if error=error_bs_claims_exceeded then
begin
for i:=1 step 1 until no_of_bs do
begin
if auxerror(i)>0 then
begin
lf:=i*12-12;
write(z,"nl",1,"sp",2,true,7,usercatbs.lf);
end;
end for;
end error=bsclaim else
begin
for i:=1,2,3 do
begin
if errortexts.p(i)>0 then
begin
if errortexts.p(i)=1 then write(z,auxerror(i)) else
begin
lf:=errortexts.p(i);
write(z,"sp",1,auxerror.lf);
end text;
end param;
end for;
end error<>bs;
end write error;
algol list.off;
message batch queue global variables and procedures;
algol list.on;
integer array q(1:qdes*qdescsize//2);
integer array b_segm_table(1:b_maxchildren,1:2);
integer array job_table(1:b_maxjobs,1:13);
<* 1: segment number
2: state (0: free, 1: enrolled, 2: running, 3: removed)
3: unique job number
4: current job priority
5: run time
6: rest time
7: childno
8: termpda
9: jobprio
10: projno
11: cpu time
12: sequence number
13: job mask (0=normal, 1=released, 2=evening)
*>
zone qz,q_in(128,1,noerror);
real timebase;
boolean cmess,qmess,bmess,jobtimermess,newqueue,day;
integer qmessline,bmessline,qsem;
algol list.on copy.treadsub;
procedure init_batch_queue;
begin
if -,newqueue then
begin
integer array field bref;
integer segm;
get_job_segm_0(false);
for segm:=1 step 1 until b_max_jobs do
begin
if get_job_segm(q,segm,false) then
begin
<*old job found*>
if q.q_job_state=staterunning then
begin
disable write(out,"nl",1,true,12,q.qjobname,q.qjobno,<: lost:>);
q.q_job_state:=q.qjobno:=0;
get_jobsegm(q,segm,true);
end else
begin
b_cur_job:=b_cur_job+1;
jobtable(segm,1):=segm;
jobtable(segm,2):=q.q_job_state;
jobtable(segm,3):=q.q_job_no;
jobtable(segm,4):=q.q_maxtime;
jobtable(segm,5):=q.qmaxtime;
jobtable(segm,6):=q.qmaxtime;
jobtable(segm,7):=0;
jobtable(segm,8):=q.contermpda;
jobtable(segm,9):=q.qmaxtime;
jobtable(segm,10):=q.conprojno shift (-8) extract 16;
jobtable(segm,11):=0;
jobtable(segm,12):=0;
jobtable(segm,13):=q.q_jobmask;
if bjobnumber<q.fi.q_job_no then b_jobnumber:=
q.fi.q_job_no;
waitch(bmessline,bref,free,0);
d.bref(1):=2;
d.bref(2):=segm;
signalch(bmessline,bref,bmess);
end initjob;
end old job;
end scan segments;
end -,newqueue;
disable write(out,"nl",2,<:batch included :>,if newqueue then
<:new:> else <:old:>,<: queue :>);
disable writetime(out,b_upd_time);;
disable write(out,<< dddddd>,
"nl",1,<:current max time:>,bmaxtime,
if day then <: day:> else <: night:>,
"nl",1,<:max time day :>,b_max_time_day//60,<: min:>,
b_max_time_day mod 60,<: sec:>,
"nl",1,<:max size day :>,b_max_size_day//1024,<: k:>,
"nl",1,<:max time night :>,b_max_time_night//60//60,<: h:>,
"nl",1,<:max size night :>,b_max_size_night//1024,<: k:>,
"nl",1,<:day to night :>,<<_____dd.dd>,b_day_to_night//100,
"nl",1,<:night to day :>,b_night_to_day//100,
"nl",1,<:parallel jobs :>,<< dddddd>,b_max_children,
"nl",1,<:jobs in queue :>,b_cur_job,
"nl",1,<:max job number :>,b_job_number);
outendcur(10);
end initbatch;
procedure batch_queue;
begin
integer i,j,res,cbn,op,mode,word,jobno,jobstate;
long array field nf;
integer array field qref,qcur,concur,bref,ct;
long array name,text(1:3);
zone pz(17,1,noerror);
stackclaim(800);
fi:=0;
repeat
waitch(qmessline,qref,qmess,0);
concur:=d.qref(2);
for i:=1,2 do name(i):=condesc.concur.condesterm(i);
open(pz,8,name,1 shift 9);
open(qin,8,name,1 shift 9);
case d.qref(1) of
begin
begin
<*submit*>
qcur:=0;
j:=condescsize//2;
for i:=2 step 1 until j do
q.qcur(i):=condesc.concur(i);
j:=j+1;
for i:=qdescsize//2 step -1 until j do
q.qcur(i):=0;
res:=0;
if d.qref.d_job_name(1)<>0 then
begin
if readusercat(d.qref.d_jobname,q.qcur,testop(7),pz) then
begin
stdclaim(q.qcur);
stdbs(q.qcur,pz);
end else
begin
res:=4;
writeerror(pz,errornameunknown,q.qcur);
end;
end jobname;
if res=0 then read_submit(qin,pz,q.qcur,false);
end submit;
begin
integer t;
<*queue*>
t:=condesc.concur.contermpda;
list_job_table(pz,if t=sysconpda then 0 else t);
end queue;
begin
integer i,jte,rest;
boolean first;
<*what*>
first:=true;
for i:=1 step 1 until maxchildren do
begin
ct:=(i-1)*ctsize;
if childtable.ct.ct_batch>0 then
begin
if first then
begin
write(pz,"nl"1,if day then <:day :> else <:night :>);
writecurtime(pz);
write(pz,"nl",1,<:user________:>,<:state____:>,
<:jobno__:>,<:time left:>);
first:=false;
end;
jte:=childtable.ct.ct_segm_queue;
rest:=jobtable(jte,6);
write(pz,"nl",1,true,12,childtable.ct.ct_jobname,
true,9,case childtable.ct.ctstate of
(<:created:>,<:running:>,<:stopped:>,<:breaked:>,
<:swopped:>),<< dddd>,childtable.ct.ctjobno);
if rest>0 then write(pz,<< dd >,rest//3600,rest mod 3600 //60,
rest mod 60);
end batch job;
end childtable scan;
end what;
begin
<*search*>
i:=0;
jobno:=d.qref(3);
repeat i:=i+1;
until i=bmaxjobs or jobno=jobtable(i,3);
if jobno=jobtable(i,3) then
begin
write(pz,"nl",1,<:job number:>,jobno,<: :>,
case jobtable(jobno,2)+1 of (
<:impossible:>,<:enrolled:>,<:running:>,<:removed:>));
end else writeerror(pz,errorjobnumbernotfound,q.qcur);
end search;
begin
<*kill*>
i:=0;
jobno:=d.qref(3);
repeat i:=i+1;
until i=bmaxjobs or jobno=jobtable(i,3);
if jobno=jobtable(i,3) then
begin
jobstate:=jobtable(i,2);
b_cur_job:=b_cur_job-1;
if jobstate=2 then
begin
waitch(bmessline,bref,free,0);
d.bref(1):=1; <*clock*>
d.bref(2):=-6; <* kill running job*>
d.bref(3):=(jobtable(i,7)-1)*ctsize;
signalch(bmessline,bref,cmess);
end job running else
for j:=2 step 1 until 15 do jobtable(i,j):=0;
qcur:=0;
q.qcur.qjobno:=0;
get_job_segm(q.qcur,i,true);
end else writeerror(pz,errorjobnumbernotfound,q.qcur);
end kill;
begin
<*release*>
i:=0;
jobno:=d.qref(3);
repeat i:=i+1;
until i=bmaxjobs or jobno=jobtable(i,3);
if jobno=jobtable(i,3) then
begin
<*job no found*>
jobtable(i,13):=1; <*released*>
end job found else
writeerror(pz,errorjobnumbernotfound,q.qcur);
end release;
begin
<*set prio*>
i:=0;
jobno:=d.qref(3);
repeat i:=i+1;
until i=bmaxjobs or jobno=jobtable(i,3);
if jobno=jobtable(i,3) then
begin
jobtable(i,4):=0;
end else writeerror(pz,errorjobnumbernotfound,q.qcur);
end setprio;
end case;
close(pz,true);
close(q_in,true);
signalch(qmessline,qref,free);
until false;
end batch queue;
procedure b_timer;
begin
integer array field bref;
real r;
stackclaim(250);
repeat
waitch(bmessline,bref,free,0);
delay(b_time_slice);
systime(5,0,r);
d.bref(1):=1;
d.bref(2):=r;
signalch(bmessline,bref,cmess);
until false;
end b_timer;
procedure run_job_timer;
begin
integer array field bref;
stackclaim(150);
repeat
waitch(bmessline,bref,jobtimermess,0);
d.bref(1):=2;
d.bref(2):=-1;
delay(b_time_slice);
signalch(bmessline,bref,bmess);
until false;
end runjobtimer;
algol list.on copy.trunbatch;
procedure write_b_des(d,z);
integer array d;
zone z;
begin
writeentry(d,z,true);
write(z,"nl",1,<:job number :>,d.qjobno,
"nl",1,<:job state :>,d.qjobstate,
"nl",1,<:job seq :>,d.qjobseq,
"nl",1,<:max time :>,d.qmaxtime,
"nl",1,<:start wanted :>,d.qstarttime,
"nl",1,<:job file name:>,d.qjobname,
"nl",1,<:printer :>,d.qprinter);
end writebdes;
algol list.off;
message primary input global variables and procedures;
algol list.on;
integer priminproc,primpda;
long array primin(1:3);
integer array line_buf(1:bmaxchildren*(l_last//2));
procedure receive_input_message;
begin
integer i,j,res,cbn,op,mode,next,type,curline,
hwreq;
integer array M,A(1:8);
integer array field bufref,inputref,child_pda,cur,fi,
bufd,reg,ct;
long array field nf,lref,address;
array field f;
integer array lrefs(1:8);
long array name,text(1:3),line(1:60);
zone mon(17,1,noerror);
stackclaim(950);
open(mon,8,monitorconsole,0);
f:=0;
address:=firstaddr(line);
for i:=1 step 1 until 60 do line(i):=0;
lref:=lrefs(1):=0;
movestring(line.lref.f,1,<:mode list.yes<10>:>);
lref:=lrefs(2):=lrefs(1)+28;
movestring(line.lref.f,3,<: = set 50<10>:>);
lref:=lrefs(3):=lrefs(2)+28;
movestring(line.lref.f,1,<:scope day :>);
lref:=lref+8+8;
line.lref(1):=long <:<10>:>;
lref:=lrefs(4):=lrefs(3)+28;
movestring(line.lref.f,1,<:o :>);
lref:=lref+4+8;
line.lref(1):=long <:<10>:>;
lref:=lrefs(5):=lrefs(4)+28;
movestring(line.lref.f,1,<:i :>);
lref:=lref+4+8;
line.lref(1):=long <:<10>:>;
lref:=lrefs(6):=lrefs(5)+28;
movestring(line.lref.f,1,<:o c<10>:>);
lref:=lrefs(7):=lrefs(6)+28;
movestring(line.lref.f,3,<:=convert :>);
lref:=lref+8+8+8;
line.lref(1):=long <:<10>:>;
lref:=lrefs(8):=lrefs(7)+28;
movestring(line.lref.f,1,<:finis<10>:>);
for i:=1 step 1 until 8 do A(i):=0;
fi:=0;
repeat
c_wait_message(priminproc,M,bufref,0);
child_pda:=core.bufref(4);
if childpda<0 then send_answer(1,bufref,A) else
begin
cbn:=0;
ct:=-ct_size;
repeat cbn:=cbn+1;
ct:=ct+ct_size;
until cbn>maxchildren or childpda=childtable.ct.ct_childpda;
if cbn>maxchildren then sendanswer(2,bufref,A) else
if childtable.ct.ct_batch=0 then send_answer(2,bufref,A) else
begin
<*it was a child*>
op:=core.bufref(5) shift (-12) extract 12;
mode:=core.bufref(5) extract 12;
if op=0 then sendanswer(1,bufref,A) else
if op<>3 then send_answer(3,bufref,A) else
begin
nf:=childpda+2;
hwreq:=core.bufref(7)-core.bufref(6)+2;
for i:=1,2 do name(i):=core.nf(i);
cur:=childtable.ct.ct_ref; <*console description*>
bufd:=bufref+10;
lref:=q.cur.q_lref;
next:=line_buf.lref.l_next;
type:=line_buf.lref.l_type;
curline:=nf:=lrefs(next);
if hwreq<28 then
begin
for i:=1,2,3 do A(i):=0;
sendanswer(1,bufref,A);
end else
begin
case next of
begin
begin <*mode list.yes*>
next:=if type=0 then 5 else 2;
end 1;
begin <* <outname> = set 50*>
for i:=1,2 do line.nf(i):=linebuf.lref.l_outname(i);
next:=3;
end 2;
begin <* scope day <outname> *>
nf:=nf+8;
for i:=1,2 do line.nf(i):=linebuf.lref.l_outname(i);
next:=4;
end 3;
begin <*o <outname> *>
nf:=nf+2;
for i:=1,2 do line.nf(i):=linebuf.lref.l_outname(i);
next:=5;
end 4;
begin <*i <jobname> *>
nf:=nf+2;
for i:=1,2 do line.nf(i):=linebuf.lref.l_jobname(i);
next:=if type=0 then 8 else 6;
end 5;
begin <* o c*>
next:=7;
end 6;
begin <* <printer> = convert <outname>*>
for i:=1,2 do line.nf(i):=linebuf.lref.l_printer(i);
nf:=nf+8+8;
for i:=1,2 do line.nf(i):=linebuf.lref.l_outname(i);
next:=8;
end 7;
begin <*finis*>
next:=8;
end 8;
end case next;
i:=address+curline;
res:=copy(bufref,i,i+28-2);
if res<>0 or monw1<28 then A(1):=A(2):=A(3):=0 else
begin
A(1):=0; A(2):=monw1; A(3):=monw3;
linebuf.lref.l_next:=next;
end;
sendanswer(1,bufref,A);
end halwords requested >=28;
end legal operation;
end it was a child;
end childpda>0;
until false;
end input message;
algol list.off;
<*************** coroutine monitor procedures ***************>
<***** delay *****
this procedure links the calling coroutine into the timerqueue and sets
the timeout value to 'timeout'. *>
procedure delay (timeout);
value timeout;
integer timeout;
begin
link(current, idlequeue);
link(current + corutimerchain, timerqueue);
d.current.corutimer:= timeout;
passivate;
d.current.corutimer:= 0;
end;
<***** pass *****
this procedure moves the calling coroutine from the head of the ready
queue down below all coroutines of lower or equal priority. *>
procedure pass;
begin
linkprio(current, readyqueue);
passivate;
end;
<***** signal ****
this procedure increases the value af 'semaphore' by 1.
in case some coroutine is already waiting, it is linked into the ready
queue for activation. the calling coroutine continues execution. *>
procedure signal (semaphore);
value semaphore;
integer semaphore;
begin
integer array field sem;
sem:= semaphore;
if d.sem.simvalue < 0 then linkprio(d.sem.simcoru, readyqueue);
d.sem.simvalue:= d.sem.simvalue + 1;
end;
<***** wait *****
this procedure decreases the value of 'semaphore' by 1.
in case the value of the semaphore is negative after the decrease, the
calling coroutine is linked into the semaphore queue waiting for a
coroutine to signal this semaphore. *>
procedure wait (semaphore);
value semaphore;
integer semaphore;
begin
integer array field sem;
sem:= semaphore;
d.sem.simvalue:= d.sem.simvalue - 1;
linkprio(current, if d.sem.simvalue < 0 then sem+simcoru else readyqueue);
passivate;
end;
<***** inspect ****
this procedure inspects the value of the semaphore and returns it in
'elements'.
the semaphore is left unchanged. *>
procedure inspect (semaphore, elements);
value semaphore;
integer semaphore, elements;
begin
integer array field sem;
sem:= semaphore;
elements:= d.sem.simvalue;
end;
<***** signalch *****
this procedure delivers an operation at 'semaphore'.
in case another coroutine is already waiting for an operation of the
kind 'operationtype' this coroutine will get the operation and it will
be put into the ready queue for activation.
in case no coroutine is waiting for the actial kind of operation it is
linked into the semaphore queue.
the calling coroutine continues execution. *>
procedure signalch (semaphore, operation, operationtype);
value semaphore, operation, operationtype;
integer semaphore, operation;
boolean operationtype;
begin
integer array field firstcoru, currcoru, op;
op:= operation;
d.op.optype:= operationtype;
firstcoru:= semaphore + semcoru;
currcoru:= d.firstcoru.next;
while currcoru <> firstcoru do
begin
if (d.currcoru.corutypeset and operationtype) extract 12 <> 0 then
begin
link(operation, 0);
d.currcoru.coruop:= operation;
linkprio(currcoru, readyqueue);
link(currcoru + corutimerchain, idlequeue);
goto exit;
end else currcoru:= d.currcoru.next;
end;
link(op, semaphore + semop);
exit:
end;
<***** waitch *****
this procedure fetches an operation from a semaphore.
in case an operation matching 'operationtypeset' is already waiting at
'semaphore' it is handed over to the calling coroutine.
in case no matching operation is waiting, the calling coroutine is
linked to the semaphore.
in any case the calling coroutine will be stopped and all corouti-
nes are rescheduled. *>
boolean procedure waitch (semaphore, operation, operationtypeset, timeout);
value semaphore, operationtypeset, timeout;
integer semaphore, operation, timeout;
boolean operationtypeset;
begin
integer array field firstop, currop;
waitch:=false;
firstop:= semaphore + semop;
currop:= d.firstop.next;
while currop <> firstop do
begin
if (d.currop.optype and operationtypeset) extract 12 <> 0 then
begin
waitch:=d.currop.optype;
link(currop, 0);
d.current.coruop:= currop;
operation:= currop;
linkprio(current, readyqueue);
passivate;
goto exit;
end else currop:= d.currop.next;
end;
linkprio(current, semaphore + semcoru);
if timeout > 0 then
begin
link(current + corutimerchain, timerqueue);
d.current.corutimer:= timeout;
end else d.current.corutimer:= 0;
d.current.corutypeset:= operationtypeset;
passivate;
if d.current.corutimer < 0 then operation:= 0
else operation:= d.current.coruop;
d.current.corutimer:= 0;
currop:= operation;
d.current.coruop:= currop;
link(current+corutimerchain, idlequeue);
exit:
end;
<***** inspectch *****
this procedure inspects the queue of operations waiting at 'semaphore'.
the number of matching operations are counted and delivered in 'elements'.
the semaphore is left unchanged. *>
procedure inspectch (semaphore, operationtypeset, elements);
value semaphore, operationtypeset;
integer semaphore, elements;
boolean operationtypeset;
begin
integer array field firstop, currop;
integer counter;
counter:= 0;
firstop:= semaphore + semop;
currop:= d.firstop.next;
while currop <> firstop do
begin
if (operationtypeset and d.currop.optype) extract 12 <> 0 then
counter:= counter + 1;
currop:= d.currop.next;
end;
elements:= counter;
end;
<***** csendmessage *****
this procedure sends the message in 'mess' to the process defined by the name
in 'receiver', and returns an identification of the message extension used
for sending the message (this identification is to be used for calling 'cwait-
answer' or 'cregretmessage'. *>
procedure csendmessage (receiver, mess, messextension);
real array receiver;
integer array mess;
integer messextension;
begin
integer bufref, messext;
messref(maxmessext):= 0;
messext:= 1;
while messref(messext) <> 0 do messext:= messext + 1;
if messext = maxmessext then <* no resources *> messext:= 0 else
begin
messcode(messext):= 1 shift 12 add 2;
mon(16) send message :(0, mess, 0, receiver);
messref(messext):= monw2;
if monw2 > 0 then messextension:= messext else messextension:= 0;
end;
end;
<***** cwaitanswer *****
this procedure asks the coroutine monitor to get an answer to the message
corresponding to 'messextension'. in case the answer has already arrived
it stays in the eventqueue until 'cwaitanswer' is called.
in case 'timeout' is positive, the coroutine is linked into the timer
queue, and in case the answer does not arrive within 'timout' seconds the
coroutine is restarted with result = 0. *>
procedure cwaitanswer (messextension, answer, result, timeout);
value messextension, timeout;
integer messextension, result, timeout;
integer array answer;
begin
integer messext;
messext:= messextension;
messcode(messext):= messcode(messext) extract 12;
link(current, idlequeue);
messop(messext):= current;
if timeout > 0 then
begin
link(current + corutimerchain, timerqueue);
d.current.corutimer:= timeout;
end else d.current.corutimer:= 0;
passivate;
if d.current.corutimer < 0 then result:= 0 else
begin
mon(18) wait answer :(0, answer, messref(messextension), 0);
result:= monw0;
baseevent:= 0;
messref(messextension):= 0;
end;
d.current.corutimer:= 0;
link(current+corutimerchain, idlequeue);
end;
<***** cwaitmessage *****
this procedure asks the coroutine monitor to give it a message, when some-
one arrives. in case a message has arrived already it stays at the event queue
until 'cwaitmessage' is called.
in case 'timeout' is positive, the coroutine is linked into the timer queue,
if no message arrives within 'timeout' seconds, the coroutine is restarted
with messbufferref = 0. *>
procedure cwaitmessage (processextension, mess, messbufferref, timeout);
value timeout, processextension;
integer processextension, messbufferref, timeout;
integer array mess;
begin
integer i;
integer array field messbuf;
proccode(processextension):= 2;
procop(processextension):= current;
link(current, idlequeue);
if timeout > 0 then
begin
link(current + corutimerchain, timerqueue);
d.current.corutimer:= timeout;
end else d.current.corutimer:= 0;
passivate;
if d.current.corutimer < 0 then messbufferref:= 0 else
begin
messbuf:= procop(processextension);
for i:=1 step 1 until 8 do mess(i):= core.messbuf(4+i);
proccode(procext):= 1 shift 12;
messbufferref:= messbuf;
baseevent:= 0;
end;
d.current.corutimer:= 0;
link(current+corutimerchain, idlequeue);
end;
<***** cregretmessage *****
this procedure regrets the message corresponding to messageexten-
sion, to release message buffer and message extension.
i/o messages are not regretable. *>
procedure cregretmessage (messageextension);
value messageextension;
integer messageextension;
begin
integer array field messbuf;
messbuf:= messref(messageextension);
mon(82) regret message :(0, 0, messbuf, 0);
messref(messageextension):= 0;
end;
<***** semsendmessage *****
this procedure sends the message 'mess' to 'receiver' and at the same time it
defines a 'signalch(semaphore, operation, operationtype)' to be performed
by the monitor, when the answer arrives.
in case there are too few resources to send the message, the operation is
returned immediately with the result field set to zero. *>
procedure semsendmessage (receiver, mess, semaphore, operation, operationtype);
value semaphore, operation, operationtype;
real array receiver;
integer array mess;
integer semaphore, operation;
boolean operationtype;
begin
integer array field op;
integer messext;
op:= operation;
messref(maxmessext):= 0;
messext:= 1;
while messref(messext) <> 0 do messext:= messext + 1;
if messext < maxmessext then
begin
messop(messext):= op;
messcode(messext):=1;
d.op(1):= semaphore;
d.op.optype:= operationtype;
mon(16) send message :(0, mess, 0, receiver);
messref(messext):= monw2;
end;
if messext = maxmessext or messref(messext) = 0 <* no resources *> then
begin <* return the operation immediately with result = 0 *>
d.op(9):= 0;
signalch(semaphore, op, operationtype);
end;
end;
<***** semwaitmessage *****
this procedure defines a 'signalch(semaphore, operation, operationtype)' to
be performed by the coroutine monitor when a message arrives to the process
corresponding to 'processextension'. *>
procedure semwaitmessage (processextension, semaphore, operation, operationtype);
value processextension, semaphore, operation, operationtype;
integer processextension, semaphore, operation;
boolean operationtype;
begin
integer array field op;
op:= operation;
procop(processextension):= operation;
d.op(1):= semaphore;
d.op.optype:= operationtype;
proccode(processextension):= 1;
end;
<***** semregretmessage *****
this procedure regrets a message sent by semsendmessage.
the message is identified by the operation in which the answer should be
returned.
the procedure sets the result field of the operation to zero, and then
returns it by performing a signalch. *>
procedure semregretmessage (operation);
value operation;
integer operation;
begin
integer i, j;
integer array field op, sem;
op:= operation;
i:= 1;
while i < maxmessext do
begin
if messref(i) > 0 and (messcode(i) = 1 and messop(i) = op) then
begin
mon(82) regret message :(0, 0, messref(i), 0);
messref(i):= 0;
sem:= d.op(1);
for j:=1 step 1 until 9 do d.op(j):= 0;
signalch(sem, op, d.op.optype);
i:= maxmessext;
end;
i:= i + 1;
end;
end;
<***** link *****
this procedure links an object (allocated in the descriptor array 'd') into
a queue of alements (allocated in the descriptor array 'd'). the queues
are all double chained, and the chainhead is of the same format as the chain
fields of the objects.
the procedure links the object immediately after the head. *>
procedure link (object, chainhead);
value object, chainhead;
integer object, chainhead;
begin
integer array field prevelement, nextelement, chead, obj;
obj:= object;
chead:= chainhead;
prevelement:= d.obj.prev;
nextelement:= d.obj.next;
d.prevelement.next:= nextelement;
d.nextelement.prev:= prevelement;
if chead > 0 then <* link into queue *>
begin
prevelement:= d.chead.prev;
d.obj.prev:= prevelement;
d.prevelement.next:= obj;
d.obj.next:= chead;
d.chead.prev:= obj;
end else
begin <* link onto itself *>
d.obj.prev:= obj;
d.obj.next:= obj;
end;
end;
<***** linkprio *****
this procedure is used to link coroutines into queues corresponding to
the priorities of the actual coroutine and the queue elements.
the object is linked immediately before the first coroutine of lower prio-
rity. *>
procedure linkprio (object, chainhead);
value object, chainhead;
integer object, chainhead;
begin
integer array field currelement, chead, obj;
obj:= object;
chead:= chainhead;
currelement:= d.chead.next;
while currelement <> chead
and d.currelement.corupriority <= d.obj.corupriority
do currelement:= d.currelement.next;
link(obj, currelement);
end;
activity(maxcoru);
goto initialization;
<*************** event handling ***************>
takeexternal:
currevent:= baseevent;
eventqueueempty:= false;
repeat
current:= 0;
prevevent:= currevent;
mon(66) test event :(0, 0, currevent, 0);
currevent:= monw2;
if monw0 < 0 <* no event *> then goto takeinternal;
if monw0 = 1 and monw1 > 0 then cmi:= monw1 else
cmi:= - monw0;
if cmi > 0 then
begin <* answer to activity zone *>
current:= firstcoru + (cmi - 1) * corusize;
linkprio(current, readyqueue);
baseevent:= 0;
end else
if cmi = 0 then
begin <* message arrived *>
receiver:= core.currevent(3);
if receiver < 0 then receiver:= - receiver;
procref(maxprocext):= receiver;
procext:= 1;
while procref(procext) <> receiver do procext:= procext + 1;
if procext = maxprocext then
begin <* receiver unknown *>
<* leave the message unchanged *>
end else
if proccode(procext) shift (-12) = 0 then
begin <* the receiver is ready for accepting messages *>
mon(26) get event :(0, 0, currevent, 0);
case proccode(procext) of
begin
begin <* message received by semwaitmessage *>
op:= procop(procext);
sem:= d.op(1);
for cmj:=1 step 1 until 8 do d.op(cmj):= core.currevent(4+cmj);
d.op(9):= currevent;
signalch(sem, op, d.op.optype);
proccode(procext):= 1 shift 12;
end;
begin <* message received by cwaitmessage *>
current:= procop(procext);
procop(procext):= currevent;
linkprio(current, readyqueue);
link(current + corutimerchain, idlequeue);
end;
end; <* case *>
currevent:= baseevent;
proccode(procext):= 1 shift 12;
end;
end <* message *> else
if cmi = -1 then
begin <* answer arrived *>
if currevent = timermessage then
begin
mon(26) get event :(0, 0, currevent, 0);
coru:= d.timerqueue.next;
while coru <> timerqueue do
begin
current:= coru - corutimerchain;
d.current.corutimer:= d.current.corutimer - clockmess(2);
coru:= d.coru.next;
if d.current.corutimer <= 0 then
begin <* timer perion expired *>
d.current.corutimer:= -1;
linkprio(current, readyqueue);
link(current + corutimerchain, idlequeue);
end;
end;
mon(16) send message :(0, clockmess, 0, clock);
timermessage:= monw2;
currevent:= baseevent;
end <* timer answer *> else
begin
messref(maxmessext):= currevent;
messext:= 1;
while messref(messext) <> currevent do messext:= messext + 1;
if messext = maxmessext then
begin <* the answer is unknown *>
<* leave the answer unchanged - it may belong to an activity *>
end else
if messcode(messext) shift (-12) = 0 then
begin
case messcode(messext) extract 12 of
begin
begin <* answer arrived after semsendmessage *>
op:= messop(messext);
sem:= d.op(1);
mon(18) wait answer :(0, d.op, currevent, 0);
d.op(9):= monw0;
signalch(sem, op, d.op.optype);
messref(messext):= 0;
baseevent:= 0;
end;
begin <* answer arrived after csendmessage *>
current:= messop(messext);
linkprio(current, readyqueue);
link(current + corutimerchain, idlequeue);
end;
end;
end else baseevent:= currevent;
end;
end;
until eventqueueempty;
<*************** coroutine activation ***************>
takeinternal:
current:= d.readyqueue.next;
if current = readyqueue then
begin
mon(24) wait event :(0, 0, baseevent, 0);
goto takeexternal;
end;
corustate:= activate(d.current.coruident mod 1000);
cmi:= corustate extract 24;
if cmi = 1 then
begin <* programmed passivate *>
goto takeexternal;
end;
if cmi = 2 then
begin <* implicit passivate in activity *>
link(current, idlequeue);
goto takeexternal;
end;
<* coroutine termination (normal or abnormal) *>
link(current, idlequeue);
goto takeexternal;
initialization:
<*************** initialization ***************>
<* chain head *>
prev:= -2; <* -2 prev *>
next:= 0; <* +0 next *>
<* corutine descriptor *>
<* -2 prev *>
<* +0 next *>
<* +2 (link field) *>
corutimerchain:= next + 4; <* +4 corutimerchain *>
<* +6 (link field) *>
coruop:= corutimerchain + 4; <* +8 coruop *>
corutimer:= coruop + 2; <*+10 corutimer *>
coruident:= corutimer + 2; <*+12 coruident *>
corupriority:= coruident + 2; <*+14 corupriority *>
corutypeset:= corupriority + 1; <*+15 corutypeset *>
corutestmask:= corutypeset + 1; <*+16 corutestmask *>
<* simple semaphore *>
<* -2 (link field) *>
simcoru:= next; <* +0 simcoru *>
simvalue:= simcoru + 2; <* +2 simvalue *>
<* chained semaphore *>
<* -2 (link field) *>
semcoru:= next; <* +0 semcoru *>
<* +2 (link field) *>
semop:= semcoru + 4; <* +4 semop *>
<* operation *>
opsize:= next - 6; <* -6 opsize *>
optype:= opsize + 1; <* -5 optype *>
<* -2 prev *>
<* +0 next *>
<* +2 operation(1) *>
<* +4 operation(2) *>
<* +6 - *>
<* . - *>
<* . - *>
trap(dump);
systime(1, 0, starttime);
for cmi:= 1 step 1 until maxmessext do messref(cmi):= 0;
clockmess(1):= 0;
clockmess(2):= timeinterval;
clock(1):= real <:clock:>;
clock(2):= real <::>;
mon(16) send message :(0, clockmess, 0, clock);
timermessage:= monw2;
readyqueue:= 4;
initchain(readyqueue);
idlequeue:= readyqueue + 4;
initchain(idlequeue);
timerqueue:= idlequeue + 4;
initchain(timerqueue);
current:= 0;
corucount:= 0;
proccount:= 0;
baseevent:= 0;
coruref:= timerqueue + 4;
firstcoru:= coruref;
simref:= coruref + maxcoru * corusize;
firstsim:= simref;
semref:= simref + maxsem * simsize;
firstsem:= semref;
opref:= semref + maxsemch * semsize + 4;
firstop:= opref;
optop:= opref + maxop * opheadsize + maxnettoop - 6;
for cmi:= coruref step 2 until optop - 2 do d(cmi//2):= 0;
reflectcore(core);
message tramtrim program;
algol list.on;
i:=ct_child_pda:=2;
i:=ct_term_pda:=i+2;
i:=ct_state:=i+2;
i:=ct_ref:=i+2;
i:=ct_job_name:=i;
i:=ct_batch:=i+10;
i:=ct_first:=i+2;
i:=ct_last:=i+2;
i:=ct_jobno:=i+2;
i:=ct_segm_swop:=i+2;
i:=ct_segm_queue:=i+2;
i:=ct_bufref:=i+2;
i:=ct_childno:=i+2;
i:=ct_usercatno:=i+2;
i:=ct_procin:=i+2;
i:=ct_procout:=i+2;
i:=ct_sem:=i+2;
ct_size:=i;
state_created:=1;
state_running:=2;
state_stopped:=3;
state_breaked:=4;
state_swopped:=5;
ownref:=owndescr;
laf:=2;
for i:=1,2 do ownname(i):=core.ownref.laf(i);
basep:=0;
maxbasep:=100;
setbasestd;
free:=false add (1 shift 1);
sysconpda:=console;
laf:=sysconpda+2;
for i:=1,2 do sysconsole(i):=core.laf(i);
stopsystem:= false add (1 shift 2);
verify:=testop(3);
catsem:=nextsem;
signal(catsem);
zsem:=nextsem;
signal(zsem);
logsem:=nextsem;
signal(logsem);
termdisconnect:=oscommunication:=osparentmess:=childrencreated:=0;
initalf(chartable);
for i:=1 step 1 until usercatusers do
for j:=1 step 1 until noofbs do
for k:=1,2 do perm_bs_claimed(i,j,k):=0;
j:=0;
for i:=reader,punch,console1,firstmt step 1 until lastmt,
firstterminal step 1 until lastterminal do
begin
if j<=lastdevice then includelist(j):=i;
j:=j+1;
end include;
lastdevice:=j-1;
for i:=(maxchildren+1)*ct_size//2 step -1 until 1 do
childtable(i):=0;
for i:=1 step 1 until maxchildren do
begin
iaf:=(i-1)*ctsize;
childtable.iaf.ct_childno:=i;
childtable.iaf.ct_sem:=nextsem;
signal(childtable.iaf.ct_sem);
end;
firstusercore:=firstaddr(usercore)-1;
for i:=1 step 1 until no_of_core_blocks+1 do
begin
coretable(i,1):=firstusercore+(i-1)*coreblocksize*512;
coretable(i,2):=0; <*free*>
end;
coretable(no_of_core_blocks+1,2):=100000;
cleararray(condesc);
for i:=1 step 1 until no_of_terminals do con_pda_table(i):=0;
open(log,0,logconsole,tw_mask);
name(1):=0;
readusercat(name,usercatbs,testop(4),log);
i:=core.ownref.bufarearef;
freebuf:=(i shift (-12) extract 12)-ownbuf;
freearea:=(i extract 12)-ownarea;
i:=core.ownref.intfuncref;
freeinternal:=(i shift (-12) extract 12)-owninternal;
for i:=1 step 1 until noofbs do
begin
iaf:=(i-1)*16;
laf:=(i-1)*12;
setownbs(usercatbs.laf,ownbs.iaf,owndrum,0,ownentries);
setownbs(usercatbs.laf,ownbs.iaf,owndisc,ownsegmdisc,ownentrydisc);
setownbs(usercatbs.laf,ownbs.iaf,owndisc1,ownsegmdisc1,ownentrydisc1);
end;
for i:=1 step 1 until noofbs do
begin
iaf:=i*16-16;
laf:=i*12-12;
j:=lookup_bs_claims(ownname,usercatbs.laf,freebs.iaf);
bs_exist(i):=j=0;
ownbs.iaf(1):=ownbs.iaf(3):=0;
if j>0 then write(out,"nl",1,true,12,usercatbs.laf,<: does not exist:>,j) else
for j:=1 step 1 until 8 do freebs.iaf(j):=freebs.iaf(j)-ownbs.iaf(j);
end;
write(out,"nl",2,"#",12,<: TRAMOS started: name=:>,ownname,
"sp",3,"#",12);
writecurtime(out);
write(out,"nl",1,
<< -ddd>,
"nl",1,<:resource free total:>,
"nl",1,<:internals :>,freeinternal,freeinternal+owninternal,
"nl",1,<:buffers :>,freebuf,freebuf+ownbuf,
"nl",1,<:areas :>,freearea,freearea+ownarea,
"nl",1,<:coreblocks :>,noofcoreblocks,
"nl",1,<:coreblocksize :>,coreblocksize);
write(out,"nl",2,<:bs resources:>,
"nl",1,true,11,<:doc:>);
write(out,"sp",12,<:temp:>,"sp",12,"sp",12,<:perm:>);
write(out,"nl",1,"sp",11);
for i:=1,2 do write(out,<:______entry___:>,<:_____segm____:>);
write(out,"nl",1,"sp",11);
for i:=1 step 1 until 4 do write(out,<:___free__total:>);
for i:=1 step 1 until noofbs do
begin
iaf:=(i-1)*16;
laf:=(i-1)*12;
write(out,"nl",1,true,11,usercatbs.laf);
if -,bs_exist(i) then write(out,<: ** does not exist:>) else
for j:=1,2,7,8 do write(out,<< dddddd>,
freebs.iaf(j),freebs.iaf(j)+ownbs.iaf(j));
end for bs;
outendcur(10);
algol list.off;
message readcommand program;
algol list.on;
att:=false add (1 shift 3);
attline:=nextsemch;
for i:=1 step 1 until noofterminals+1 do
begin
j:=nextop(8);
signalch(attline,j,free);
end;
for i:=1 step 1 until noofterminals do
begin
fi:=(i-1)*condescsize;
con_desc.fi.con_term_no:=i;
condesc.fi.con_ref:=fi;
condesc.fi.conaccess:=nextsem;
signal(condesc.fi.conaccess);
end;
ownpda:=owndescr;
messaddress:=nextprocext(ownpda);
for i:=1 step 1 until maxmess do
begin
j:=nextcoru(1,100,true);
newactivity(j,j,receivemess,i);
end mess;
for i:=1 step 1 until noofterminals do
begin
j:=nextcoru(2,100,true);
newactivity(j,0,readcommand,i);
end;
algol list.off;
message parent message: program;
algol list.on;
pmess:=false add (1 shift 4);
pmessline:=nextsemch;
for i:=1 step 1 until maxpmess do
begin
j:=nextop(8);
signalch(pmessline,j,free);
end;
j:=nextcoru(3,300,true);
newactivity(j,j,receive_parent_message);
algol list.off;
message error messages program;
init_error_text(errortexts);
message batch queue: program;
algol list.on;
setbasestd;
tail(1):=swopsegm;
laf:=2;
for i:=1,2 do tail.laf(i):=swopdoc(i);
for i:=6 step 1 until 10 do tail(i):=0;
i:=createentry(swop,tail);
if i=3 then
begin
removeentry(swop);
i:=createentry(swop,tail);
end;
if i>0 then alarm(<:***swop area :>,swop,i);
permentry(swop,3);
resetbase;
begin
integer cs,cb,blocks;
cs:=coreblocksize*512;
blocks:=(bmaxsizeday+cs-2)//cs;
if blocks<=noofcoreblocks then
begin
cb:=0;
for cb:=1 step 1 until blocks do coretable(cb,2):=ownpda;
bchildfirst:=coretable(1,1);
bchildlast :=coretable(blocks+1,1)-2;
end else
begin
write(out,"nl",1,<:batch inactive, no free core :>,
bmaxsizeday,<: needed:>);
bmaxchildren:=0;
end;
end local;
qmess:=false add (1 shift 5);
bmess:=false add (1 shift 6);
cmess:=false add (1 shift 7);
jobtimermess:=false add (1 shift 8);
qsem:=nextsem;
signal(qsem);
qmessline:=nextsemch;
for i:=1 step 1 until qdes do
begin
j:=nextop(12);
signalch(qmessline,j,free);
end;
systime(5,0,timebase);
timebase:=timebase/100;
day:=(timebase>b_night_to_day and timebase<b_day_to_night);
b_max_time:=if day then b_max_time_day else b_max_time_night;
bmessline:=nextsemch;
for i:=1 step 1 until bmaxchildren do
begin
bsegmtable(i,1):=0;
bsegmtable(i,2):=(i-1)*bmaxsizenight//512;
end;
for i:=1 step 1 until b_maxjobs+4 do
begin
j:=nextop(6);
signalch(bmessline,j,free);
end;
for i:=1 step 1 until b_max_jobs do
for j:=1 step 1 until 10 do
job_table(i,j):=0;
setbaseusercat;
readbfp(<:newq:>,newqueue,false);
i:=lookupentry(qname,tail);
if i>0 or tail(1)<=b_max_jobs or newqueue then
begin
newqueue:=true;
tail(1):=b_max_jobs+1;
laf:=2;
for i:=1,2 do tail.laf(i):=own_disc(i);
for i:=7 step 1 until 10 do tail(i):=0;
removeentry(qname);
i:=createentry(qname,tail);
if i>0 then alarm(<:Queue no resources :>,qname,i);
end;
permentry(qname,3);
open(qz,4,qname,1 shift 9);
if newqueue then
begin
outrec6(qz,512);
fi:=0;
for i:=1 step 1 until 256 do qz.fi(i):=0;
qz.fi.q0_max_time_day:=b_max_time_day;
qz.fi.q0_max_size_day:=b_max_size_day;
qz.fi.q0_max_time_night:=b_max_time_night;
qz.fi.q0_max_size_night:=b_max_size_night;
qz.fi.q0_night_to_day:=b_night_to_day;
qz.fi.q0_day_to_night:=b_day_to_night;
qz.fi.q0_upd_time:=b_upd_time:=systime(7,0,0.0);
outrec6(qz,512);
for i:=1 step 1 until 256 do qz.fi(i):=0;
for i:=3 step 1 until b_max_jobs+1 do outrec6(qz,512);
setposition(qz,0,0);
end newqueue;
resetbase;
for i:=1 step 1 until qdes do
begin
fi:=(i-1)*qdescsize;
for j:=2 step 1 until qdescsize//2 do q.fi(j):=0;
q.fi.conref:=fi;
q.fi.conaccess:=nextsem;
signal(q.fi.conaccess);
end;
j:=nextcoru(4,300,true);
newactivity(j,j,batch_queue);
j:=nextcoru(5,50,true);
newactivity(j,j,run_batch);
j:=nextcoru(6,25,true);
newactivity(j,j,b_timer);
j:=nextcoru(7,25,true);
newactivity(j,j,run_job_timer);
algol list.off;
message primary input message: program;
algol list.on;
setbasestd;
primin(1):=long <:primi:> add 'n';
primin(2):=0;
createpseudoprocess(primin);
primpda:=process_description(primin);
priminproc:=nextprocext(primpda);
j:=nextcoru(8,40,true);
newactivity(j,j,receive_input_message);
algol list.off;
message automatic upstart: program;
<*start up processes*>
algol list.on;
setbaseusercat;
name(1):=long <:osaut:>; name(2):=0;
i:=lookup_entry(name,tail);
if i=0 and tail(1)>0 then
begin
<*start up area present*>
zone start(128,1,stderror);
open(start,4,<:osaut:>,0);
i:=nextfreeterm(sysconpda);
write(out,"nl",1,<:start up area present:>);
outendcur(0);
readcommandlist(start,condesc.curcondesc,true);
end else lock:=false;
resetbase;
write(out,"nl",1,<:ready:>,"nl",1);
outendcur(10);
if fpout then closeout;
algol list.off;
if simref <> firstsem then initerror(1, false);
if semref <> firstop - 4 then initerror(2, false);
if coruref <> firstsim then initerror(3, false);
if opref <> optop + 6 then initerror(4, false);
if proccount <> maxprocext -1 then initerror(5, false);
goto takeexternal;
dump:
end;
end
▶EOF◀