|
DataMuseum.dkPresents historical artifacts from the history of: RC3500 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC3500 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 36864 (0x9000)
Types: TextFileVerbose
Names: »stdroutines«
└─⟦2c55ea56f⟧ Bits:30001844 SW-save af projekt 1000, Alarm-system
└─⟦6b41451d2⟧
└─⟦this⟧ »stdroutines«
prefix break;
procedure break(var sh : shadow; excode : integer);
(********************************************************************)
(* *)
(* break *)
(* *)
(********************************************************************)
const
break_exception = rsexcfirst + 1;
stop_command = 0;
start_command = 1;
var
semp : ^ semaphore;
boo : boolean;
begin
if nil(sh.r) then
excptcall(break_exception)
else
begin
checkstack(break_appetite);
wait(own.exitref,own.secret_pointer^(stopsem)^);
lock sh.r as p : ext_incarnation_descriptor do
asgnsempaddr(semp,p.exit_semaphore);
boo := not locked(semp^);
semp := own.secret_pointer^(monitorsem);
sh.r^.u1 := stop_command;
signal(sh.r,semp^);
wait(sh.r,own.exit_semaphore);
lock sh.r as p : ext_incarnation_descriptor do
with p do
if boo then
begin
exic := entry_point;
entry_point := exception_point;
exception_mask := excode;
dumplm := maxstack;
end;
sh.r^.u1 := start_command;
signal(sh.r,semp^);
wait(sh.r,own.exit_semaphore);
release(own.exitref)
end
end;
prefix copychm;
function copychm(var r1,r2 : reference) : integer;
(*************************************************************************)
(* *)
(* copychm *)
(* *)
(*************************************************************************)
const
ok = 0;
notok = 1;
var
boo : boolean;
begin
copychm := notok;
boo := empty(r1) and (not nil(r1)) and (not nil(r2));
if boo then
if (r1^.messagekind = 0) and (r2^.messagekind < 0) then
begin
r1^.messagekind := r2^.messagekind;
r1^.size := r2^.size;
copychm := ok
end
end;
prefix create;
function create(incarnation_name : alfa; proces : processrec; var sh : shadow; storage : integer):integer;
(********************************************************************)
(* *)
(* create *)
(* *)
(********************************************************************)
const
stopstate = -1;
(* allocator results *)
allocator_no_storage = 0;
(* create results *)
create_ok = 0;
shadow_def = 1;
process_not_linked = 2;
no_storage = 3;
(* process_descriptor linkstates *)
unlinked = 0;
internal_linked = 1;
external_linked = 2;
nil_value = addr(base_type(0,1,0,0,0),0);
minsize = 75;
var
stack : reference;
pointer : addr;
mstart : addr;
index : integer;
index1 : integer;
dope : dope_vector;
function udiv(a,b : integer) : integer;
external;
function umod(a,b : integer) : integer;
external;
function usub(a,b : integer) : integer;
external;
begin
if not nil(sh.r) then
create := shadow_def
else
if (storage > 0) and (storage <= minsize) then
create := no_storage (* just simple test... *)
else
(* check that a process is linked to the process descriptor *)
if proces.processref^.link_state = unlinked then
create := process_not_linked
else
begin
checkstack(create_appetite);
wait(own.exitref,own.secret_pointer^(stopsem)^);
(* init allocator request *)
with own.exitref^ do
begin
size := minint;
answer := ref(own.exit_semaphore);
if storage = 0 then
begin
with proces.processref^ do
begin
start := process_inf_ref;
if link_state = internal_linked then
lock own.exitref as p : process_inf do
storage := p.default_appetite
else
lock own.exitref as p : descriptor_segment do
storage := p.default_appetite
end
end;
u1 := 0 * 4;
u2 := 1; (* number of messages *)
if storage <= minsize then
storage := minint;
u3 := udiv(storage,256);
u4 := umod(storage,256);
end;
signal(own.exitref,own.secret_pointer^(allocsem)^);
wait(sh.r,own.exit_semaphore);
(* the request message is pushed on the *)
(* eventually allocated data message by the allocator *)
pop(own.exitref,sh.r);
if own.exitref^.u2 = allocator_no_storage then
(* shadow remains nill *)
create := no_storage
else
begin
sh.r^.answer := ref(own.exit_semaphore);
dope := dope_vector(range_descriptor(0,maxint),2);
with sh.r^ do
begin
index := udiv(start.disp,2);
mstart := start;
mstart.disp := 0;
end;
lock sh.r as inc : ext_incarnation_descriptor do
begin
with inc do
begin
pu := 0;
level := 0;
incstate := stopstate;
activequeue := addr_of(chain);
chainhead := nil_value;
exic := addr(base_type(0,0,0,0,0),0);
(* this assignment to exic must be synced with printexcept *)
dumpsf := sh.r^.start.disp + 1;
asgnaddrpref(processref,proces.processref);
index1 := index + usub(storage,1);
defineptr(pointer,mstart,index1,dope);
maxstack := pointer.disp + 1;
dumplm := maxstack;
dumpps := 0;
timer := 0;
semchain := nil_value;
refchain := nil_value;
shadowchain := nil_value;
msg_chain := nil_value;
exit_semaphore := nil_value;
delaychain := nil_value;
exitref := nil_value;
statistic := nil_value;
asgnaddrsec(secret_pointer,own.secret_pointer);
plinetable := nil_value;
incname := incarnation_name;
end;
with proces.processref ^ do
begin
own.exitref^.size := minint;
own.exitref^.start := process_inf_ref;
incarnationcount := incarnationcount + 1;
if link_state = internal_linked then
begin (* this begin_end is caused by the indent program *)
lock own.exitref as p : process_inf do
with p do
begin
inc.entry_point := entry_point;
inc.exception_point := exception_point;
inc.exit_point := exit_point;
inc.dumplu := last_param_offset;
end
end
else
begin (* external linked *)
lock own.exitref as p : descriptor_segment do
with p do
begin
inc.entry_point := entry_point;
inc.exception_point := exception_point;
inc.exit_point := exit_point;
inc.dumplu := last_param_offset;
end
end;
end; (* with *)
defineptr(pointer,mstart,index+(inc.dumplu-proces.size_of_params)div 2,dope);
copywords(pointer,proces.firstparam,proces.size_of_params div 2);
defineptr(pointer,mstart,index - 1 + inc.dumplu div 2,dope);
inc.dumplu := pointer.disp + 1;
sh.r^.u3 := stdpriority + 128;
create := create_ok;
end
end;
release(own.exitref);
end;
end;
prefix definetimer;
procedure definetimer (onoff: boolean);
var
lf, gf: addr;
begin
checkstack(20);
getlfgf (lf, gf);
wait (own.exitref, own.secret_pointer^(stopsem)^);
with own.exitref^ do
begin
u1 := 1;
u2 := ord(onoff); (* 0==off, 1==on *)
answer := ref(own.exit_semaphore);
start := gf;
end;
signal (own.exitref, own.secret_pointer^(iotimersem)^);
wait (own.exitref, own.exit_semaphore);
release (own.exitref);
end;
prefix empty;
function empty(var r : reference) : boolean;
(*******************************************************************)
(* *)
(* empty *)
(* *)
(*******************************************************************)
begin
empty := true;
if not nil(r) then
empty := nil(r^.stackchain)
end;
prefix exception;
procedure exception(cause : integer);
(*********************************************************************)
(* *)
(* exception *)
(* *)
(*********************************************************************)
const
kind = 0;
var
lf , gf : addr;
function udiv(a,b : integer) : integer;
external;
function umod(a,b : integer) : integer;
external;
begin
getlfgf(lf,gf);
own.dumpsf := lf.disp;
wait(own.exitref,own.secret_pointer^(stopsem)^);
with own.exitref ^ do
begin
size := minint; (* a whole memory module *)
start := gf;
<*
start.disp := start.disp - 1;
*>
answer := ref(own.exit_semaphore);
u1 := kind;
u2 := udiv(cause,256);
u3 := umod(cause,256);
end;
signal(own.exitref,own.secret_pointer^(exceptionsem)^);
wait(own.exitref,own.exit_semaphore);
release(own.exitref);
end;
;prefix ___exit___rc;
procedure ___exit___rc;
(*******************************************************************)
(* *)
(* exit *)
(* *)
(*******************************************************************)
(* this procedure is called when an
incarnation enters the exit_code *)
const
stop_command = 0;
start_command = 1;
external_linked = 2;
unload_command = 2;
var
msg1 : reference;
saved_sem : ^ semaphore;
sem_p : ^ semaphore;
boo : boolean;
lf, gf : addr;
begin
(* wait for remove from father *)
wait(own.exitref,own.exit_semaphore);
getlfgf (lf, gf);
with own.exitref^ do
begin
saved_sem := answer;
answer := ref(own.exit_semaphore);
size := minint;
(* also initialize message for: 'definetimer(false)' *)
u1 := 1; (* = define timer *)
u2 := 0; (* = false *)
start := gf; (* = own inc descr *)
end;
(* send 'definetimer' to iotimer-process *)
signal (own.exitref, own.secret_pointer^(iotimersem)^);
wait (own.exitref, own.exit_semaphore);
(* stop and unload all children *)
while not nil(own.shadowchain) do
begin
with own.shadowchain^ do
if not nil(r) then
begin
lock r as p : ext_incarnation_descriptor do
asgnsempaddr(sem_p,p.exit_semaphore);
boo := not locked(sem_p^);
sem_p := own.secret_pointer^(monitorsem);
r^.u1 := stop_command;
signal(r,sem_p^);
wait(r,own.exit_semaphore);
lock r as p : ext_incarnation_descriptor do
begin
p.level := 0; (* restart is on level 0 *)
if boo then
p.entry_point := p.exit_point;
end;
r^.u1 := start_command;
signal(r,sem_p^);
wait(r,own.exit_semaphore);
lock r as p : ext_incarnation_descriptor do
begin
(* the child is now waiting at *)
(* the beginning of its exitcode *)
asgnsempaddr(sem_p,p.exit_semaphore);
signal(own.exitref,sem_p^);
(* wait until the child has finished its cleanup *)
wait(own.exitref,own.exit_semaphore);
end;
r^.u1 := stop_command;
signal(r,own.secret_pointer^(monitorsem)^);
wait(r,own.exit_semaphore);
lock r as p : ext_incarnation_descriptor do
begin
own.exitref^.size := minint;
own.exitref^.start := p.processref;
lock own.exitref as proc : process_descriptor do
begin
p.incstate := proc.link_state; (* incstate used as work *)
p.timer := proc.incarnationcount; (* timer used as work *)
end;
if (p.incstate = external_linked) and (p.timer = 0) then
begin
own.exitref^.u1 := unload_command;
signal(own.exitref,own.secret_pointer^(linkersem)^);
wait(own.exitref,own.exit_semaphore);
end;
end;
r^.answer := r^.owner;
return (r); (* release stack of child *)
end;
own.shadowchain := own.shadowchain^.next;
end;
(* scan chain of messages allocated in this incarnation *)
while not nil(own.msg_chain) do
begin
with own.msg_chain^ do
begin
owner := own.secret_pointer^(deallocatorsem);
answer := owner;
end;
own.msg_chain := own.msg_chain^.msg_chain
end;
(* scan chain of reference variables *)
while not nil(own.refchain) do
begin
asgnaddrref(own.exit_point,own.refchain^); (* own.exit_point used as work *)
(* remove the eventually locked bit *)
own.exit_point.base.lockbit := 0;
asgnrefaddr(own.refchain^,own.exit_point);
if not nil(own.refchain^) then
begin
return(own.refchain^);
end;
nextrefp(own.refchain);
end;
(* scan chain of semaphores declared in this incarnation *)
(* only messages may be pending at a semaphore *)
(* because all children are removed at this point *)
sem_p := own.semchain;
while not nil(sem_p) do
begin
while open(sem_p^) do
begin
wait(msg1,sem_p^);
return(msg1)
end;
sem_p := sem_p^.semchain
end;
(* decrement incarnation count in process_descriptor *)
with own.processref^ do
incarnationcount := incarnationcount - 1;
(* return exit_message to father *)
own.exitref^.answer := saved_sem;
return(own.exitref);
(* do something until i die ! *)
wait(own.exitref,own.exit_semaphore)
end;
prefix _initpool_rc;
procedure _initpool_rc(var s : semaphore; number,msize : integer);
(**********************************************************************)
(* *)
(* initpool *)
(* *)
(**********************************************************************)
(* msize is number of words ! *)
const
opcode = 0;
initpool_exception = rsexcfirst + 0;
var
r : reference;
stack : reference;
function udiv(a,b : integer) : integer;
external;
function umod(a,b : integer) : integer;
external;
begin
checkstack(initpool_appetite);
wait(own.exitref,own.secret_pointer^(stopsem)^);
with own.exitref^ do
begin
u1 := opcode;
u2 := number;
if msize < 0 then
msize := minint;
u3 := udiv(msize,256);
u4 := umod(msize,256);
answer := ref(own.exit_semaphore);
end;
signal(own.exitref,own.secret_pointer^(allocsem)^);
wait(stack,own.exit_semaphore);
pop(own.exitref,stack);
if own.exitref^.u2 = 0 then
begin
release(own.exitref);
excptcall(initpool_exception);
end
else
begin
while not nil(stack) do
begin
pop(r,stack);
linkmessage(r);
r^.owner := ref(s);
release(r); (* signal(r,owner) *)
end;
release(own.exitref);
end;
end;
prefix link;
function link(external_name : alfa; var pr : process_descriptor) : integer;
(*******************************************************************)
(* *)
(* link *)
(* *)
(*******************************************************************)
const
link_command = 1;
ok = 0;
allready_linked = 6;
unlinked = 0;
internal_linked = 1;
external_linked = 2;
begin
<*
printnl;
printtext('link call ');
printtext(external_name);
*>
if pr.link_state <> unlinked then
link := allready_linked
else
begin
checkstack(link_appetite);
wait(own.exitref,own.secret_pointer^(stopsem)^);
pr.name := external_name;
with own.exitref^ do
begin
size := minint;
start := addr_of_proc(pr);
answer := ref(own.exit_semaphore);
u1 := link_command;
end;
signal(own.exitref,own.secret_pointer^(linkersem)^);
wait(own.exitref,own.exit_semaphore);
<*
printnl;
printtext('result = ');
printnumber(result,2);
printnl;
*>
if own.exitref^.u2 = ok then
with pr do
begin
link_state := external_linked;
incarnationcount := 0;
end;
link := own.exitref^.u2;
release(own.exitref);
end
end;
prefix remove;
procedure remove(var sh : shadow);
(*******************************************************************)
(* *)
(* remove *)
(* *)
(*******************************************************************)
const
remove_exception = rsexcfirst + 2;
stop_command = 0;
start_command = 1;
var
semp : ^ semaphore;
boo : boolean;
begin
with sh do
begin
if nil(r) then
excptcall(remove_exception)
else
begin
checkstack(remove_appetite);
wait(own.exitref,own.secret_pointer^(stopsem)^);
lock r as p : ext_incarnation_descriptor do
asgnsempaddr(semp,p.exit_semaphore);
boo := not locked(semp^);
semp := own.secret_pointer^(monitorsem);
r^.u1 := stop_command;
signal(r,semp^);
wait(r,own.exit_semaphore);
lock r as p : ext_incarnation_descriptor do
begin
p.level := 0;
if boo then
p.entry_point := p.exit_point;
end;
r^.u1 := start_command;
signal(r,semp^);
wait(r,own.exit_semaphore);
lock r as p : ext_incarnation_descriptor do
begin
(* set answer semaphore pointer *)
own.exitref^.answer := ref(own.exit_semaphore);
(* activate child waiting for this message in its exit_code *)
asgnsempaddr(semp,p.exit_semaphore);
signal(own.exitref,semp^);
(* wait for the dead child *)
wait(own.exitref,own.exit_semaphore)
end;
r^.u1 := stop_command; (* remove child from activequeue *)
signal(r,own.secret_pointer^(monitorsem)^);
wait(r,own.exit_semaphore);
r^.answer := r^.owner;
return(r);
release(own.exitref);
end
end
end;
prefix reservech;
function reservech(var ch_msg : reference; level,mask : integer) : integer;
(*********************************************************************)
(* *)
(* reservech *)
(* *)
(*********************************************************************)
const
opcode = 1;
notnil = 2;
function udiv(a,b : integer) : integer;
external;
function umod(a,b : integer) : integer;
external;
begin
if nil(ch_msg) then
begin
checkstack(reservech_appetite);
wait (own.exitref, own.secret_pointer^(stopsem)^);
with own.exitref^ do
begin
u1 := opcode;
u2 := level;
u3 := udiv(mask,256);
u4 := umod(mask,256);
answer := ref(own.exit_semaphore);
end;
signal(own.exitref,own.secret_pointer^(allocsem)^);
wait(ch_msg,own.exit_semaphore);
pop (own.exitref, ch_msg); (* seperate into r=ownmess, ch-msg=channel-mess *)
reservech := 1 - own.exitref^.u2;
release(own.exitref);
end
else
reservech := notnil
end;
prefix sendtimer;
procedure sendtimer(var r : reference);
(********************************************************************)
(* *)
(* sendtimer *)
(* *)
(********************************************************************)
begin
signal(r,own.secret_pointer^(timersem)^)
end;
prefix setpriority;
procedure setpriority(priority : integer);
(*******************************************************************)
(* *)
(* setpriority *)
(* *)
(*******************************************************************)
const
setpriority_command = 2;
var
lf,gf : addr;
begin
checkstack(20);
getlfgf(lf,gf);
wait(own.exitref,own.secret_pointer^(stopsem)^);
with own.exitref^ do
begin
u1 := setpriority_command;
if (priority>=minpriority) and (priority <= maxpriority) then
u3 := priority + 128;
answer := ref(own.exit_semaphore);
size := minint;
start := gf
end;
signal(own.exitref,own.secret_pointer^(monitorsem)^);
wait(own.exitref,own.exit_semaphore);
release(own.exitref);
end; (* setpriority *)
prefix start;
procedure start(var sh : shadow; priority : integer);
(********************************************************************)
(* *)
(* start *)
(* *)
(********************************************************************)
const
start_exception = rsexcfirst + 3;
start_command = 1;
begin
if nil(sh.r) then
excptcall(start_exception)
else
begin
checkstack(start_appetite);
wait(own.exitref,own.secret_pointer^(stopsem)^);
with sh.r^ do
begin
u1 := start_command;
if (priority >= minpriority) and (priority <= maxpriority) then
u3 := priority + 128;
end;
signal(sh.r,own.secret_pointer^(monitorsem)^);
wait(sh.r, own.exit_semaphore);
release(own.exitref);
end;
end;
prefix stop;
procedure stop(var sh : shadow);
(********************************************************************)
(* *)
(* stop *)
(* *)
(********************************************************************)
const
stop_exception = rsexcfirst + 4;
stop_command = 0;
begin
if nil(sh.r) then
excptcall(stop_exception)
else
begin
checkstack(stop_appetite);
wait(own.exitref,own.secret_pointer^(stopsem)^);
sh.r^.u1 := stop_command;
signal(sh.r,own.secret_pointer^(monitorsem)^);
wait(sh.r, own.exit_semaphore);
release(own.exitref);
end
end;
prefix unlink;
function unlink(var pr : process_descriptor) : integer;
(********************************************************************)
(* *)
(* unlink *)
(* *)
(********************************************************************)
const
ok = 0;
notlinked = 1;
process_active = 2;
unlinked = 0;
unload_command = 2;
var
result : integer;
begin
<*
printnl;
printtext('unlink call ');
printtext(pr.name);
*>
if pr.incarnationcount <> 0 then
unlink := process_active
else
begin
checkstack(unlink_appetite);
wait(own.exitref,own.secret_pointer^(stopsem)^);
with own.exitref^ do
begin
size := minint;
start := addr_of_proc(pr);
answer := ref(own.exit_semaphore);
u1 := unload_command;
end;
signal(own.exitref,own.secret_pointer^(linkersem)^);
wait(own.exitref,own.exit_semaphore);
<*
printnl;
printtext('result = ');
printnumber(result,2);
printnl;
*>
if own.exitref^.u2 = ok then
pr.link_state := unlinked;
unlink := own.exitref^.u2;
release(own.exitref)
end
end;
\f
prefix checkstack;
procedure checkstack(appetite : integer);
(************************************************************************)
(* *)
(* checkstack *)
(* *)
(************************************************************************)
begin
if appetite < 9 then
appetite := 0
else
appetite := appetite - 9;
bcheck
end;
\f
prefix openzone;
procedure openzone ( (* opens a zone for driver comm. *)
var z: zone; (* the zone to be opened *)
driv: ^semaphore; (* driver process sem *)
answ: ^semaphore; (* answers arrives here *)
bufs : integer; (* no of buffers *)
var home: pool 1; (* ownerpool for buffers *)
v1, v2, v3, v4: byte ); (* u values in message headers *)
const
output = 2;
firstbuf = 6; (* general driver buffer *)
type
buffer = record (* for driver comm. *)
first, (* pointer to 1st char *)
last, (* pointer to last output char *)
next: integer; (* pointer to last+1 input char *)
end;
begin
with z do
begin
driver:= driv;
answer:= answ;
u2val := v2;
state := 0;
readstate:= -1;
nextp:= firstbuf;
for bufs:= bufs downto 1 do
begin
alloc ( cur, home, answer^);
cur^.u1:= v1;
cur^.u2:= 0;
cur^.u3:= v3;
cur^.u4:= v4;
if ult(16383,cur^.size) then
lastpos := maxint
else
lastpos := cur^.size * 2 - 1;
lock cur as buf: buffer do with buf do
begin
first:= firstbuf;
last:= lastpos;
next:= first
end;
signal ( cur, free )
end
end
end (* of openzone *)
\f
prefix openopzone;
procedure openopzone ( (* opens a zone for operator comm. *)
var z: zone; (* the zone to be opened *)
driv: ^semaphore; (* driver process sem *)
answ: ^semaphore; (* answers arrives here *)
bufs : integer; (* no of buffers *)
var home: pool 1; (* ownerpool for buffers *)
v1, v2, v3, v4: byte ); (* u values in message headers *)
const
output = 2;
firstbuf = 6+alfalength; (* operator buffer *)
type
opbuffer = record (* for operator comm. *)
first, (* pointer to 1st char *)
last, (* pointer to last output char *)
next: integer; (* pointer to last+1 input char *)
name: alfa; (* process inc name *)
end;
begin
with z do
begin
driver:= driv;
answer:= answ;
u2val := v2;
state := 0;
readstate:= -1;
nextp:= firstbuf;
for bufs:= bufs downto 1 do
begin
alloc ( cur, home, answer^);
cur^.u1:= v1;
cur^.u2:= 0;
cur^.u3:= v3;
cur^.u4:= v4;
if ult(16383,cur^.size) then
lastpos := maxint
else
lastpos := cur^.size * 2 - 1;
lock cur as buf: opbuffer do with buf do
begin
name:= own.incname;
first:= firstbuf;
last:= lastpos;
next:= first
end;
signal ( cur, free )
end
end
end (* of openopzone *)
\f
prefix alloc;
procedure alloc(var r : reference; var p : pool 1; var sem : semaphore);
(******************************************************************)
(* *)
(* alloc *)
(* *)
(******************************************************************)
begin
balloc
end;
\f
prefix outaddr;
procedure outaddr( var z : zone; a : addr );
begin
with a.base do
outhex(z,(((-lockbit*2+nill)*256+moduletype)*32+mem_no)*2+nullbit,4);
outchar(z,'.');
outhex(z,a.disp,4)
end; (* outaddr *)
\f
prefix outhex;
procedure outhex ( (* writes an integer as hexadecimal *)
var z: zone; (* specifies the document *)
num: integer; (* number to be written *)
pos: integer ); (* write positions *)
type
table = array (0..15) of char;
const
hextab = table ("0","1","2","3","4","5","6","7",
"8","9","a","b","c","d","e","f" );
var
bit0: byte:= 0;
begin
if num < 0 then
begin
bit0:= 8;
num:= num - minint;
end;
outfill ( z, sp, pos-4);
outchar ( z, hextab(bit0+num div (16*16*16)));
outchar ( z, hextab(num div (16*16) mod 16));
outchar ( z, hextab(num div 16 mod 16));
outchar ( z, hextab(num mod 16));
end (* of outhex *)
\f
prefix outdate;
procedure outdate(var z : zone; date : coded_date );
begin
with date do
begin
outinteger(z, year_after_1900 + 1900, 5);
outchar(z,'.');
if month < 10 then outchar(z,'0');
outinteger(z, month, 1);
outchar(z,'.');
if day < 10 then outchar(z,'0');
outinteger(z, day, 1 );
end;
end;
\f
prefix outtime;
procedure outtime ( var z : zone; time : coded_time );
begin
with time do
begin
if hour < 10 then outinteger(z, 0 , 1 );
outinteger(z, hour , 1 );
outchar(z, '.' );
if minute < 10 then outinteger(z, 0, 1 );
outinteger(z, minute , 1 );
end; (* with *)
end;
\f
prefix outinteger;
procedure outinteger ( (* write an integer as decimal *)
var z: zone; (* specifies the document *)
num: integer; (* the integer *)
pos: integer ); (* no of writepositions *)
(*
pos may give some spaces before the number, but all
digits are written.
*)
var
neg: boolean;
i: byte:= 1;
digits: array (1..5) of char;
begin
if num = minint then
begin
outfill ( z, sp, pos-6);
outtext ( z, "-32768# ")
end
else
begin
neg:= num < 0;
if neg then
begin
pos:= pos-1;
num:= -num
end;
repeat
digits(i):= chr ( num mod 10 + ord("0"));
num:= num div 10;
i:= i+1
until num = 0;
outfill ( z, sp, pos-i+1);
if neg then outchar ( z, "-");
for i:= i-1 downto 1 do outchar ( z, digits(i))
end
end (* of outinteger *)
\f
prefix opin;
procedure opin ( var z: zone); (* request input *)
var
msg: reference;
begin
with z do
if open ( free) then
begin
wait ( msg, free);
msg^.u2:= u2val;
signal ( msg, driver^)
end
end (* of opin *)
\f
prefix opanswer;
procedure opanswer ( (* transfers a message to zone z *)
var msg: reference; (* a message with operator input *)
var z: zone ); (* an input zone *)
begin
signal ( msg, z.dataready)
end (* of opanswer *)
\f
prefix optest;
function optest ( var z: zone ): boolean;
(*
optest is true if the zone has some data ready.
i. e. opwait will not wait.
*)
begin
optest := open ( z.dataready)
end (* of optest *)
\f
prefix opwait;
procedure opwait ( (* waits for input to z *)
var z: zone; (* specifies the document *)
var inputpool: pool 1 ); (* input buffer pool *)
const
read = 1;
type
zonebuffer = record
first, last, next: integer
end;
var
n: integer:= 0; (* msg counter *)
operatorinput: boolean;
begin
with z do
if nil ( cur) then
begin
if not open ( dataready) then (* wait for input answer *)
begin
repeat
wait ( cur, answer^);
operatorinput:= ownertest ( inputpool, cur) and ( cur^.u1 mod 8 = read);
signal ( cur, dataready);
n:= n+1
until operatorinput;
for n:= n downto 2 do (* send other messages back into queue *)
begin
wait ( cur, dataready);
signal ( cur, answer^);
end;
end;
wait ( cur, dataready);
state:= cur^.u2;
lock cur as buf: zonebuffer do nextp:= buf.first
end
end (* of opwait *)
\f
prefix ininteger;
procedure ininteger ( (* reads a decimal number *)
var z: zone; (* specifies the document *)
var num: integer ); (* value read or 0 *)
(*
syntax: (0..n)*(not digit), (0..1)*sign, (1..5)*digit
z.readstate = 0 if value assigned.
*)
const
max = 3276; (* max integer div 10 *)
digits = (. "0".."9" .);
wanted = (. "0".."9", nl .);
var
prev, t: char:= sp;
d: byte:= 0;
sign: integer;
begin
num:= 0;
repeat
prev:= t;
inchar ( z, t)
until t in wanted;
if t <> nl then (* a number is met *)
begin
if prev = "-" then sign:= -1 else sign:= +1;
while ( num < max ) and ( t in digits ) do
begin
num:= num*10 - ord("0") + ord( t);
inchar ( z, t)
end;
if ( num <= max ) and ( t in digits ) then (* include last digit *)
begin
d:= ord ( t) - ord("0");
if 2*d < 16-sign then (* accept *)
begin
num:= num*10;
z.nextp:= z.nextp+1
end
else d:= 0
end;
num:= sign*num + sign*d;
z.readstate:= 0;
z.nextp:= z.nextp-1
end
end (* of ininteger *)
\f
prefix inhex;
procedure inhex ( (* reads a hexadecimal number *)
var z: zone; (* specifies the document *)
var num: integer ); (* value read or 0 *)
(*
syntax: (0..n)*(not hexdigit), (1..4)*hexdigit
z.readstate = 0 if value assigned.
*)
const
hexdigits = (. "0".."9", "a".."f" .);
wanted = (. nl, "0".."9", "a".."f" .);
var
t: char;
a, b, c, d: byte:= 0; (* 4 digits *)
begin
num:= 0;
repeat inchar ( z, t) until t in wanted;
if t <> nl then (* a number is met *)
begin
while ( a = 0 ) and ( t in hexdigits ) do
begin
a:= b; b:= c; c:= d;
if ord ( t) <= ord ("9") then
d:= ord ( t) - ord ("0") else
d:= ord ( t) - ord ("a") + 10;
inchar ( z, t)
end;
num:= ((((a+8) mod 16 -8)*16+b)*16+c)*16+d;
z.readstate:= 0;
z.nextp:= z.nextp-1
end
end (* of inhex *)
\f
prefix inname;
procedure inname ( (* reads a name from z *)
var z: zone; (* specifies the document *)
var name: alfa ); (* inname *)
(*
syntax: (0..n)*sp, 1*letter, (0..11)*alfanum
readstate = 0 if name assigned.
you may initialize name before inname.
*)
const
letters = (. "A".."]", "_" , "a".."}" .);
alfanum = (. "A".."]", "_" , "a".."}", "0".."9" .);
var
t: char;
i: byte:= 0;
begin
repeat inchar ( z, t) until t <> sp;
if t in letters then (* read the name *)
begin
repeat
i:= i+1;
name(i):= t;
inchar ( z, t);
until ( i = alfalength ) or not ( t in alfanum );
z.readstate:= 0;
z.nextp:= z.nextp-1;
end
else
if z.readstate = 0 then
begin
z.nextp := z.nextp - 1;
z.readstate := 1
end
end (* of inname *)
\f
\f
prefix outnl;
procedure outnl( var z : zone );
begin
outchar(z,nl);
outend(z)
end; (* outnl *)
\f
prefix outfill;
procedure outfill ( (* repeated outchar *)
var z: zone; (* specifies the document *)
filler: char; (* character to be written *)
rep: integer ); (* repeat counter *)
begin
for rep:= rep downto 1 do outchar ( z, filler)
end (* of outfill *)
\f
prefix outtext;
procedure outtext ( (* writes text on z *)
var z: zone; (* specifies the document *)
text: alfa ); (* text to be written
# works as textstop *)
var
i: byte:= 1;
begin
while text(i) <> "#" do
begin
outchar ( z, text(i));
if i = alfalength then text(i):= "#" else i:= i+1
end
end (* of outtext *)
\f
prefix outchar;
procedure outchar ( (* writes 1 char in zone z *)
var z: zone; (* specifies the document *)
t: char ); (* character to be written *)
type
zonebuffer = record
first, last, next: integer;
end;
begin
with z do
begin
if nil ( cur) then (* get a buffer *)
begin
wait ( cur, free);
state:= cur^.u2;
lock cur as buf : zonebuffer do
nextp := buf.first
end;
lock cur as buf : array (0..lastpos) of char do
buf(nextp) := t;
nextp := uadd(nextp,1);
if ult(lastpos,nextp) then
outend(z)
end
end (* of outchar *)
\f
prefix inchar;
procedure inchar ( (* reads next character *)
var z: zone; (* specifies the document *)
var t: char ); (* delivered character or nl *)
begin
t:= nl;
with z do
if nil ( cur) then readstate:= -1
else
begin
readstate:= 0;
lock cur as buf : record
first,last,next : integer;
chars : array (6..lastpos) of char
end do
if ult(nextp,buf.next) then
t:= buf.chars(nextp)
else readstate:= -1;
if readstate = -1 then signal ( cur, free)
else
nextp := uadd(nextp,1)
end
end (* of inchar *)
\f
prefix outend;
procedure outend ( (* sends outputbuffer to driver *)
var z: zone ); (* specifies the document *)
type
zonebuffer = record
first, last, next: integer;
(* the rest is silence here *)
end;
begin
with z do
if not nil ( cur) then
begin
lock cur as buf: zonebuffer do buf.last:= nextp-1;
cur^.u2:= u2val;
signal ( cur, driver^)
end
end (* of outend *)
.
«eof»