|
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 - download
Length: 9216 (0x2400)
Types: TextFile
Names: »htudskriv «
└─⟦cde9d517b⟧ Bits:30007477 RC8000 Backup tape fra HT's bus-radio system
└─⟦6a563b143⟧
└─ ⟦this⟧ »htudskriv «
htudskriv.
:4: udskriv: erklæringer
\f
message procedure out_xxx_bits side 1 - 810406/cl;
procedure outboolbits(zud,b);
value b;
zone zud;
boolean b;
begin
integer i;
for i:= -11 step 1 until 0 do
outchar(zud,if b shift i then '1' else '.');
end;
procedure outintbits(zud,j);
value j;
zone zud;
integer j;
begin
integer i;
for i:= -23 step 1 until 0 do
begin
outchar(zud,if j shift i extract 1 = 1 then '1' else '.');
if i<>0 and abs(i) mod 6 = 0 then outchar(zud,'sp');
end;
end;
\f
message procedure skriv_id side 1 - 820301/cl;
procedure skriv_id(z,id,lgd);
value id,lgd;
integer id,lgd;
zone z;
begin
integer type,p,li,lø,bo;
type:= id shift (-22);
case type+1 of
begin
<* 1: bus *>
begin
p:= write(z,<<d>,id extract 14);
if id shift (-14) <> 0 then
p:= p + write(z,".",1,string garagenavn(id shift (-14)));
end;
<* 2: linie/løb *>
begin
li:= id shift (-12) extract 10;
bo:= id shift (-7) extract 5;
if bo<>0 then bo:= bo + 'A' - 1;
lø:= id extract 7;
p:= write(z,<<d>,li,false add bo,(bo<>0) extract 1,"/",1,lø);
end;
<* 3: gruppe *>
begin
if id shift (-21) = 4 <* linie-gruppe *> then
begin
li:= id shift (-5) extract 10;
bo:= id extract 5;
if bo<>0 then bo:= bo + 'A' - 1;
p:= write(z,<<d>,li,false add bo,(bo<>0) extract 1);
end
else <* special-gruppe *>
p:= write(z,"G",1,<<d>,id extract 7);
end;
<* 4: telefon *>
begin
bo:= id shift (-20) extract 2;
li:= id extract 20;
case bo+1 of
begin
p:= write(z,string kanalnavn(li));
p:= write(z,<:K*:>);
p:= write(z,<:OMR :>,string områdenavn(li));
p:= write(z,<:OMR*:>);
end;
end;
end case;
write(z,"sp",lgd-p);
end skriv_id;
<*+3*>
\f
message skriv_new_sem side 1 - 810520/cl;
procedure skriv_new_sem(z,type,ref,navn);
value type,ref;
zone z;
integer type,ref;
string navn;
<* skriver en identifikation af en semafor 'ref' i zonen z.
type: 1=binær sem
2=simpel sem
3=kædet sem
ref: semaforreference
navn: semafornavn, max 18 tegn
*>
begin
disable if testbit29 then
write(z,"nl",1,"sp",26*(type-1),case type of(<:bs:>,<:ss:>,<:cs:>),
true,5,<<zddd>,ref,true,19,navn);
end;
\f
message procedure skriv_newactivity side 1 - 810520/hko/cl;
<**> procedure skriv_newactivity(zud,actno,cause);
<**> value actno,cause;
<**> zone zud;
<**> integer actno,cause;
<**> begin
<*+2*>
<**> if testbit28 then
<**> begin integer array field cor;
<**> cor:= coroutine(actno);
<**> write(zud,<: coroutine::>,<< dd>,actno,<: ident::>,
<**> << zdd>,d.cor.coruident//1000);
<**> end;
<**> if -, testbit23 then goto skriv_newact_slut;
<*-2*>
<**> write(zud,"nl",1,<:newactivity(:>,<<d>,actno,
<**> <:) cause=:>,<<-d>,cause);
<**> if cause<1 then write(zud,<: !!!:>);
<**> skriv_coru(zud,actno);
<**> skriv_newact_slut:
<**> end skriv_newactivity;
<*-3*>
<*+99*>
\f
message procedure skriv_activity side 1 - 810313/hko;
<**> procedure skriv_activity(zud,actno);
<**> value actno;
<**> zone zud;
<**> integer actno;
<**> begin
<**> integer i;
<**> integer array iact(1:12);
<**>
<**> i:=system(12,actno,iact);
<**> write(zud,"nl",1,<: activity(:>,<<d>,actno,<:) af :>,i,"sp",1,
<**> if i=0 then <:neutral:> else (case sign(iact(3))+2 of
<**> (<:disable:>,<:monitor:>,<:activity:>)),<: mode:>);
<**> if i>0 and actno>0 and actno<=i then
<**> begin
<**> write(zud,"nl",1,"sp",4,<:tilstand= :>,case iact(8)+1 of
<**> (<:tom:>,<:passivate:>,
<**> <:implicit passivate:>,<:activate:>));
<**> if iact(1)<>0 then
<**> write(zud,<: ventende på message:>,iact(1));
<**> if iact(7)>0 then
<**> write(zud,"nl",1,"sp",4,<:virtuel stak::>,iact(7),"sp",2,
<**> <:hovedlager stak benyttes af activity(:>,<<d>,
<**> iact(2));
<**> write(zud,"nl",1,"sp",4,<:stak(top,bund,sidst,csr,cza)=:>,
<**> iact(4),iact(5),iact(6),iact(10),iact(11));
<**> if iact(9)<> 1 shift 22 then
<**> write(zud,"nl",1,"sp",4,<:'head of zonechain'=:>,iact(9));
<**> write(zud,"nl",1,"sp",4,<:'trap chain'=:>,iact(12));
<**> end;
<**> end skriv_activity
<*-99*>
<*+98*>
\f
message procedure identificer side 1 - 810520/cl;
procedure identificer(z);
zone z;
begin
disable write(z,<:coroutine::>,<< dd>,curr_coruno,
<: ident::>,<< zdd >,curr_coruid);
end;
\f
message procedure skriv_coru side 1 - 810317/cl;
<**> procedure skriv_coru(zud,cor_no);
<**> value cor_no;
<**> zone zud;
<**> integer cor_no;
<**> begin
<**> integer i;
<**> integer array field cor;
<**>
<**>
<**> write(zud,"nl",1,<: coroutine: :>,<<d>,cor_no);
<**>
<**> cor:= coroutine(cor_no);
<**> if cor = -1 then
<**> write(zud,<: eksisterer ikke !!!:>)
<**> else
<**> begin
<**> write(zud,<:; ident = :>,<<zdd>,d.cor.coruident//1000,
<**> <: refbyte: :>,<<d>,cor,"nl",1,
<**> <: prev: :>,<<dddd>,d.cor.prev,"nl",1,
<**> <: next: :>,d.cor.next,"nl",1,
<**> <: timerchain.prev: :>,d.cor(corutimerchain//2-1),"nl",1,
<**> <: timerchain.next: :>,d.cor.corutimerchain,"nl",1,
<**> <: opchain.prev: :>,d.cor(coruop//2-1),"nl",1,
<**> <: opchain.next: :>,d.cor.coruop,"nl",1,
<**> <: timer: :>,d.cor.corutimer,"nl",1,
<**> <: priority: :>,d.cor.corupriority,"nl",1,
<**> <: typeset: :>);
<**> for i:= -11 step 1 until 0 do
<**> write(zud,if d.cor.corutypeset shift i then <:1:> else <:.:>);
<**> write(zud,"nl",1,<: testmask: :>);
<**> for i:= -11 step 1 until 0 do
<**> write(zud,if d.cor.corutestmask shift i then <:1:> else <:.:>);
<*+99*>
<**> skriv_activity(zud,cor_no);
<*-99*>
<**> end;
<**> end skriv_coru;
<*-98*>
<*+98*>
\f
message procedure skriv_op side 1 - 810409/cl;
<**> procedure skriv_op(zud,opref);
<**> value opref;
<**> integer opref;
<**> zone zud;
<**> begin
<**> integer array field op;
<**> real array field raf;
<**> integer lgd,i;
<**> real t;
<**>
<**> raf:= data;
<**> op:= opref;
<**> write(zud,"nl",1,<:op:>,<<d>,opref,<:::>);
<**> if opref<first_op ! optop<=opref then
<**> begin
<**> write(zud,<: !!! illegal reference !!!:>,"nl",1);
<**> goto slut_skriv_op;
<**> end;
<**>
<**> lgd:= d.op.opsize;
<**> write(zud,"nl",1,<<d>,
<**> <: opsize :>,d.op.opsize,"nl",1,
<**> <: optype :>);
<**> for i:= -11 step 1 until 0 do
<**> write(zud,if d.op.optype shift i then <:1:> else <:.:>);
<**> write(zud,"nl",1,<<d>,
<**> <: prev :>,d.op.prev,"nl",1,
<**> <: next :>,d.op.next);
<**> if lgd=0 then goto slut_skriv_op;
<**> write(zud,"nl",1,<<d>,
<**> <: kilde :>,d.op.kilde extract 10,"nl",1,
<**> <: tid :>,<<zddddd>,systime(4,d.op.tid,t),<:.:>,t,"nl",1,<<d>,
<**> <: retur-sem :>,if d.op.retur<>0 then <:cs:> else <:--:>,<<b>,
d.op.retur,"nl",1,
<**> <: opkode :>,<<b>,d.op.opkode shift (-12),"sp",1,<<d>,
<**> d.op.opkode extract 12,"nl",1,
<**> <: resultat :>,d.op.resultat,"nl",2,
<**> <:data::>);
<**> skriv_hele(zud,d.op.raf,lgd-data,1278);
<**>slut_skriv_op:
<**> end skriv_op;
<*-98*>
\f
message procedure corutable side 1 - 810406/cl;
procedure corutable(zud);
zone zud;
begin
integer i;
integer array field cor;
write(zud,"ff",1,<:***** coroutines *****:>,"nl",2,
<:no id ref chain timerch opchain timer pr:>,
<: typeset testmask:>,"nl",2);
for i:= 1 step 1 until maxcoru do
begin
cor:= coroutine(i);
write(zud,<<zd>,i,<< zdd>,d.cor.coruident//1000,<< dddd>,cor,
d.cor.prev,d.cor.next,d.cor(corutimerchain//2-1),
d.cor.corutimerchain,d.cor(coruop//2-1),d.cor.coruop,<< ddddd>,
d.cor.corutimer,<< dd>,d.cor.corupriority);
outchar(zud,'sp');
outboolbits(zud,d.cor.corutypeset);
outchar(zud,'sp');
outboolbits(zud,d.cor.corutestmask);
outchar(zud,'nl');
end;
end;
▶EOF◀