|
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: 23040 (0x5a00)
Types: TextFileVerbose
Names: »exttxtkom«
└─⟦a41ae585a⟧ Bits:30001842 SW-save af projekt 1000, Alarm-system
└─⟦72244f0ef⟧
└─⟦this⟧ »exttxtkom«
; <*-------------------------komlib--------------------------
;
; modulnavn (algol7 text) : exttxtkom
; _ (object code) : komlib
; k|rt f|rste gang d. : 24.08.78
; form}l : externe procedurer til kommune-gruppen
; projekt : system
; _
; programm|r : jkp + hjep + olej + niels jacobsen
; _
; sidste rettelsesdag : 14/5-79
; udf|rt af : Ole Jacobsen
; _
; dokumentation : *
; _
; moduler der benyttes : ingen
; _
; bem{rkninger : ingen
;*>
;<*-------------------------hj{lp-----------------------------*>
indl{stal = algol
external
long procedure indl{stal(udtext);
string udtext;
begin
long indtal;
write(out,<:<10>:>,udtext,<: ?= :>);
setposition(out,0,0);
read(in,indtal);
indl{stal := indtal;
end indl{stal;
end;
ask = algol
external
boolean procedure ask(asktext);
string asktext;
begin
own boolean erkaldt, skinput;
integer ch,dum;
if -, erkaldt then
begin
integer array beskrivelse(1:20);
erkaldt := true;
getzone(in, beskrivelse);
skinput := beskrivelse(1) = 8;
end;
write(out,<:<10>:>,asktext,<: ? :>);
setposition(out,0,0);
for dum := readchar(in,ch) while ch<> 106 and ch <> 110 do
if ch<> 10 and ch <> 32 then
begin
write(out,<:svar j'a' eller n'ej':>);
write(out,<:<10>:>,asktext, <: ? :>);
if -, skinput then
system(9, 0, <:fejl i svar:>);
setposition(out,0,0);
for dum := readchar(in, ch) while ch <> 10 do;
end for;
ask := ch = 106;
if skinput then
begin
for dum := readchar(in, ch) while ch <> 10 do;
end;
end ask;
end;
checkddmm}} = algol
external
boolean procedure checkddmm}}(dato);
value dato;
integer dato;
checkddmm}} := (dato // 10000 < 32) and (dato //100 mod 100 < 13);
end;
checkmod11 = algol
external
boolean procedure checkmod11(tal);
value tal;
long tal;
begin
long tal1;
integer sum, v{gt;
sum := 0;
tal1 := tal;
for v{gt := 1, (case v{gt of (2, 3, 4, 5, 6, 7, 2)) while tal1 > 0 do
begin
sum := sum + (tal1 mod 10) * v{gt;
tal1 := tal1 // 10;
end;
checkmod11 := sum mod 11 = 0;
end checkmod11;
end;
lavcheckcif = algol
external
long procedure lavcheckcif(tal);
value tal;
long tal;
begin
long tal1;
integer sum, v{gt;
tal1 := tal;
sum := 0;
for v{gt := 3, (case v{gt of (2, 3, 4, 5, 6, 7, 2)) while tal1 > 0 do
begin
sum := sum + (tal1 mod 10) * v{gt;
tal1 := tal1 // 10;
end;
sum := (22 - sum mod 11) mod 11;
if sum = 10 then sum := 50;
lavcheckcif := tal * 100 + sum;
end lavcheckcif;
end;
tiexp = algol
external
long procedure tiexp(eksponent);
value eksponent;
integer eksponent;
begin
tiexp := case eksponent + 1 of (
1,10,100,1000,10000,100000,1000000,10000000,100000000,
1000000000,10000000000,100000000000,1000000000000,10000000000000,
100000000000000);
end tiexp;
end;
getdeltal = algol
external
integer procedure get_del_tal(tal,pos1,pos2);
<* proceduren henter tallet i positionerne pos1 til pos2
i tal fra h|jre mod venstre *>
value tal,pos1,pos2;
integer pos1,pos2;
long tal;
begin
get_del_tal := tal//tiexp(pos1 -1) mod tiexp(pos2 - pos1 +1);
end get_del_tal;
end;
lavkortstr = algol
external
long procedure lav_kort_streng(tal,antalpos);
value tal, antalpos;
integer tal,antalpos;
<* resultatet er en long med tal pakket med iso v{rdier for cifrene
i antalpos positioner fra venstre *>
begin
long fak , str;
integer j;
fak := tiexp(antalpos-1);
str := 0;
for j := 1 step 1 until antalpos do
begin
str := str shift 8 + (tal//fak) + 48;
tal := tal mod fak;
fak := fak // 10;
end for;
lav_kort_streng := str shift((6 - antalpos) * 8);
end lav_kort_streng;
end;
nulstil = algol
external
procedure nulstil(rec,l{ngde);
<* l{ngde er angivet i bytes*>
value l{ngde;
integer l{ngde;
real array rec;
begin
real array field raf;
raf := 4;
rec(1) := real <::>;
tofrom(rec.raf,rec,l{ngde-4);
end nulstil;
end;
initrek = algol
external
procedure initrek(rek,l{ngdefelt,l{ngde);
value l{ngde;
integer l{ngde;
integer field l{ngdefelt;
array rek;
begin
nulstil(rek,l{ngde);
rek.l{ngdefelt := l{ngde;
end initrek;
end;
skrivdagsda = algol
external
procedure skrivdagsdato(z);
zone z;
begin
own integer dag, m}ned, }r;
if dag = 0 then
begin
integer dagsdato;
real kl,kl1;
systime(1,0,kl);
dagsdato := entier(systime(2,kl,kl1));
dag := dagsdato // 10000;
m}ned := dagsdato // 100 mod 100;
if m}ned > 12 then m}ned := 0;
}r := dagsdato mod 100 + 1900;
end;
write(z,<<dd>, dag,<:. :>);
write(z, case m}ned + 1 of
(
<:fejl :>,
<:januar :>,
<:februar :>,
<:marts :>,
<:april :>,
<:maj :>,
<:juni :>,
<:juli :>,
<:august :>,
<:september:>,
<:oktober :>,
<:november :>,
<:december :>));
write(z,<< dddd>,}r);
end skrivdagsdato;
end;
skrivdato = algol
external
procedure skrivdato(z,dato);
<* proceduren udskriver datoen p} formen:
dd. <m}ned> }}}}
det fylder 18 tegn.
*>
zone z;
integer dato;
begin
integer dag, m}ned, }r;
integer pos;
dag := dato // 10000;
m}ned := dato // 100 mod 100;
if m}ned > 12 or m}ned < 0 then m}ned := 0;
}r := dato mod 100 + 1900;
pos := write(z,<<dd>, dag,<:. :>);
pos := pos + write(z, case m}ned + 1 of
(
<:fejl:>,
<:januar:>,
<:februar:>,
<:marts:>,
<:april:>,
<:maj:>,
<:juni:>,
<:juli:>,
<:august:>,
<:september:>,
<:oktober:>,
<:november:>,
<:december:>));
pos := pos + write(z,<< dddd>,}r);
write(z, false add 32, 18 - pos);
end skrivdato;
end;
skrivugedag = algol
external
\f
procedure skrivugedag(z,dato);
<* skriver <ugedag> den <dato> *> <* fylder 30 tegn *>
value dato;
integer dato;
zone z;
begin
integer dag, m}ned, }r, n, u;
dag := dato//10000;
m}ned := dato//100 mod 100;
}r := 1900 + dato mod 100;
if m}ned<3 then
begin
m}ned := m}ned + 12;
}r := }r - 1;
end;
n := 13*(m}ned+1)//5 + 5*}r//4 - }r//100 + }r//400 + dag - 1;
u := n mod 7;
write (z,case u+1 of(<:s|ndag :>,<:mandag :>,<:tirsdag:>,<:onsdag :>,<:torsdag:>,<:fredag :>,<:l|rdag :>));
write (z,<: den :>);
skrivdato (z,dato);
end skrivugedag;
end;
initalfabet = algol
external
procedure init_alfabet(alfabet);
<* proceduren initialiserer parameteren, alfabet, med et standard-alfabet*>
integer array alfabet;
begin
integer j;
for j := 0 step 1 until 127 do
alfabet(j) := (case j + 1 of (
0, 7, 7, 7, 7, 7, 7, 7,
7, 7, 8, 7, 8, 0, 7, 7,
7, 7, 7, 7, 7, 7, 7, 7,
7, 8, 7, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 7, 7, 5,
7, 7, 7, 3, 7, 3, 4, 7,
2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 7, 7, 7, 7, 7, 7,
7, 6, 6, 6, 6, 6, 6, 6,
6, 6, 6, 6, 6, 6, 6, 6,
6, 6, 6, 6, 6, 6, 6, 6,
6, 6, 6, 6, 6, 6, 7, 7,
7, 6, 6, 6, 6, 6, 6, 6,
6, 6, 6, 6, 6, 6, 6, 6,
6, 6, 6, 6, 6, 6, 6, 6,
6, 6, 6, 6, 6, 6, 7, 0)) shift 12 + j;
end initalfabet;
end;
skrivvt = algol
external
\f
procedure skriv_vt(z, antal, spec_styrestrimmel);
value antal, spec_styrestrimmel;
zone z;
integer antal;
boolean spec_styrestrimmel;
begin
if spec_styrestrimmel then
write(z, false add 11, 1)
else
write(z, false add 10, antal);
end skriv_vt;
end;
plus1dato = algol
external
integer procedure plus1dato(dato);
value dato;
integer dato;
<* procedure giver datoen for dagen efter den opgivne dato *>
begin
integer d, m, };
d := dato // 10000 + 1;
m := dato // 100 mod 100;
} := dato mod 100;
if m < 0 or 12 < m then m := 0;
if d > (case m+1 of (99, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)) then
begin
d := 1;
m := m + 1;
if m = 13 then
begin
m := 1;
} := } + 1;
end;
end;
plus1dato := d*10000 + m*100 + };
end plus1dato;
end;
skrivtidsfo = algol
external
procedure skrivtidsfo(z,txt);
<* procedure til udskrift af tidsforbrug med henblik p} effektivitetsanalyse.
formatet er:
klokken tt mm ss txt ( som er parameter )
siden sidst i sek. siden start i tt mm ss
cputid realtid cputid realtid
*>
zone z;
string txt;
begin
own boolean erkaldt,sp;
own real cputid,realtid,starttid;
real cpuforb, realtidnu,klokke,cpuklok,realklok;
if -, erkaldt then
begin
integer dagsdato;
real kl;
erkaldt := true;
cputid := systime(1,0,starttid);
realtid := starttid;
write(z,<:<10>:>,<: f|rste tidsstatistik udskrift :>);
dagsdato := entier(systime(2,starttid,kl));
sp := false add 32;
skrivugedag(z,dagsdato);
write(z,<:<10>:>);
end;
cpuforb := systime(1,0,realtidnu);
systime(2,realtidnu,klokke);
systime(2,cpuforb,cpuklok);
systime(2,realtidnu - starttid,realklok);
write(z,<:<10>:>,<:klokken :>,<<dd dd dd>,klokke,sp,5,txt,<:<10>:>,
<: siden sidst i sek. siden start tt mm ss:>,<:<10>:>,
<: cpu : :>,<<dddd.dd>,cpuforb - cputid,
<: real : :>,realtidnu - realtid,sp,5,
<: cpu : :>,<<dd dd dd>,cpuklok,
<: real : :>,realklok,<:<10>:>);
realtid := realtidnu;
cputid := cpuforb;
end skrivtidsfo;
end;
;<* -------------------------filehj{lp-----------------------------*>
connectdoc = algol
external
\f
integer procedure connect_doc(z,name,segm);
<*****************************************>
value segm;
integer segm;
string name;
zone z;
begin
comment proceduren }bner 'z' til 'name'.
hvis katalogindgangen ikke findes og segm > 0, erkl{res der et bs-areal
med navnet 'name' og en st|rrelse p} 'segm' segmenter.
hvis segm < 0 s{ttes check_wanted bit'en i zonens free parameter.
procedurens returv{rdi angiver dokumentets 'kind';
integer modekind,i,k;
integer array tail(1:10),descr(1:20);
real array field raf;
real array doc(1:2);
close(z,true);
movestring(doc,1,name);
k:=1;
open(z,0,string doc(increase(k)),0);
i:=monitor(42)lookup_entry:(z,0,tail);
if i <> 0 then
begin
<* indgangen findes ikke *>
if segm <= 0 then
begin
k:=1;
write(out,<:<10>:>,<:bs-area :>,string doc(increase(k)),<:findes ikke:>);
system(9,i,<:<10>*connect:>);
end
else
begin
comment der laves et bas-area;
close(z,true);
k:=1;
open(z,4,string doc(increase(k)),0);
for i:=1 step 1 until 10 do tail(i):=0;
tail(1):=segm;
tail(6) := systime(7, 0, 0.0);
i:=monitor(40)create_entry:(z,0,tail);
if i <> 0 then
begin
k:=1;
write(out,<:<10>:>,<:bs-area :>,string doc(increase(k)),<: kan ikke oprettes:>);
system(9,i,<:<10>*connect:>);
end;
end;
end
else
if tail(1) > 0 then
begin
close(z,true);
k:=1;
open(z,4,string doc(increase(k)),0);
connect_doc:=4;
end
else
if tail(1) <= 0 then
begin
<* indgangen <> bs-area *>
modekind:=tail(1) extract 23;
close(z,true);
k:=1;
raf:=2;
open(z,modekind,string tail.raf(increase(k)),0);
if modekind extract 12 = 18 then setposition(z,tail(7),tail(8));
connect_doc:=modekind extract 12;
end;
if segm < 0 then
begin
comment der |nskes kontrol af checksum;
getzone6(z,descr);
descr(11):= 1 shift 23;
setzone6(z,descr);
end;
end procedure connect_doc;
end;
fpfejl= algol
external
integer procedure fpfejl(type);
<*****************************>
value type;
integer type;
begin
write(out,<:<10>:>,<:fejl i fil-parametre:>,<:<10>:>,case type of (
<:parameterfejl:>,
<:ukendt parameter:>,
<:parameter l{st tidligere:>,
<:parameter ikke efterfulgt af punktum:>,
<:ukendt testudskrift:>,
<:ukendt sk{rmmode :>), <:<10>:>);
system(9,type,<:<10>fp_kald:>);
end procedure fpfejl;
end;
generatenam = algol
external
\f
procedure generate_nam(name);
<****************************>
array name;
comment proceduren generer et
bs_area navn;
begin
zone
_ z(128,1,stderror);
integer array
_ ia(1:20);
integer array field
_ iaf;
integer
_ i;
iaf:=0;
i:=monitor(68)generate_name:(z,0,ia);
if i <> 0 then system(9,i,<:<10>*genname:>);
getzone6(z,ia);
for i:=2 step 1 until 5 do name.iaf(i-1):=ia(i);
end procedure generate nam;
end;
removeentry = algol
external
\f
procedure remove_entry(name);
<***************************>
array name;
comment proceduren fjerner
omr}det <name>;
begin
zone
_ z(128,1,stderror);
integer array
_ ia(1:20);
integer
_ i;
i:=1;
connect_doc(z,string name(increase(i)),21);
i:=monitor(48)remove_entry:(z,0,ia);
close(z,true);
end procedure remove_entry;
end;
getexactpos = algol
external
\f
procedure getexactpos(z,block,rel,pwfree);
<*********************************************>
zone z;
integer block,rel,pwfree;
begin
comment proceduren finder den n|jagtige position
p} dokumentet tilknyttet z;
integer array
_ zdescr(1:20);
getzone6(z,zdescr);
block:=zdescr(9);
rel:=zdescr(14)+zdescr(16)-zdescr(19)-4*zdescr(20)//zdescr(18)*(zdescr(17)-1);
pwfree:=if zdescr(13) = 6 then zdescr(11) else zdescr(12);
end procedure getexactpos;
end;
setexactpos = algol
external
procedure setexactpos(z,block,rel,pwfree);
<*********************************************>
zone z;
integer block,rel,pwfree;
begin
integer array
_ zdescr(1:20);
integer
_ actblock,
_ zstate;
getzone6(z,zdescr);
actblock:=zdescr(9);
zstate:=zdescr(13);
if actblock = block and zstate <> 0 then
zdescr(14):=rel+zdescr(19)+4*zdescr(20)//zdescr(18)*(zdescr(17)-1)
else
begin
setposition(z,0,block);
inrec6(z,0);
zdescr(9):=block;
zdescr(13):=zstate;
zdescr(14):=rel+zdescr(19);
zdescr(15):=zdescr(19)+4*zdescr(20)//zdescr(18);
zdescr(17):=1;
end;
zdescr(11):=zdescr(12):=pwfree;
zdescr(16):=0;
setzone6(z,zdescr);
end procedure setexactpos;
end;
getstdfp = algol
external
\f
boolean procedure get_std_fp(outfiletxt,infiletxt,fejllistetxt,test);
<*proceduren l{ser f|lgende standard-parametre:
<outfiletxt> = programkald in.<infiletxt> fejl.<fejllistetxt> test.<et eller flere tal>
det foruds{ttest, at test er erkl{ret som (1:20), og for alle tal, der forekommer
med . imellem efter test vil test(tallet) blive sat til true
*>
array outfiletxt,infiletxt,fejllistetxt;
boolean array test;
begin
real array ra(1:2);
boolean array l{st(1:4);
integer j,p,cas;
integer testnedre, test|vre;
testnedre := system(3, test|vre, test);
for j := testnedre step 1 until test|vre do test(j) := false;
for j := 1 step 1 until 4 do l{st(j) := false;
p := 1;
if system(4,1,ra) shift (-12) = 6 then
begin
<* outfile forekommer *>
if system(4,0,ra) extract 12 <> 10 then fpfejl(1);
tofrom(outfiletxt,ra,8);
p:= 2;
end;
for j := system(4,p,ra) while j <> 0 do
if j<> 4 shift 12 + 10 then fpfejl(1)
else
begin
cas := if ra(1) = real<:in:> then 1 else
if ra(1) = real <:fejl:> then 2 else
if ra(1) = real <:test:> then 3 else 4;
if cas = 4 then
begin
get_std_fp := false;
goto exit;
end;
if l{st(cas) then fpfejl(3) else l{st(cas) := true;
j := system(4,p+1,ra);
if j shift (-12) <> 8 then fpfejl(4);
case cas of
begin
tofrom(infiletxt,ra,8);
tofrom(fejllistetxt,ra,8);
for p:= p+1 while system(4,p,ra) = 8 shift 12 + 4 do
if ra(1) >= testnedre and ra(1) <= test|vre then
test(ra(1)) := true else fpfejl(5);
end case;
if cas <> 3 then p := p+ 2;
end for;
get_std_fp := true;
exit:;
end get_std_fp;
end;
l{sfptal = algol
external
\f
long procedure l{sfptal(text);
<* proceduren l{ser et tal i fp-kaldet. det skal st} p} formen <text>.<tal> *>
string text;
begin
real array ra, textra (1:2);
integer j, fpnr, lg;
lg := movestring(textra, 1, text);
fpnr := 1;
l{sfptal := 0;
for j := system(4, fpnr, ra) while j <> 0 do
begin
if j = 4 shift 12 add 10 <* det er et navn med space foran *>
and ra(1) = textra(1)
and (if lg = 2 then ra(2) = textra(2) else true) then
begin
fpnr := fpnr + 1;
if system(4, fpnr, ra) = 8 shift 12 + 4 <* punktum med et tal efter *> then
l{sfptal := ra(1)
else
fpfejl(4);
end
else
fpnr := fpnr + 1;
end;
end l{sfptal;
end;
l{sfpboo = algol
external
\f
boolean procedure l{sfpboo(text,boo);
<* proceduren l{ser en boolean i fp-kaldet. det skal st} p} formen <text>.<svar>
og resultatet leveres i boo , som true hvis <svar> er 'yes' eller 'ja'
og false hvis <svar> er 'no' eller 'nej'.
findes <text> ikke i fpkaldet, er boo u{ndret *>
string text;
boolean boo;
begin
real array ra, textra (1:2);
integer j, fpnr, lg;
l{sfpboo := false;
lg := movestring(textra, 1, text);
fpnr := 1;
for j := system(4, fpnr, ra) while j <> 0 do
begin
if j = 4 shift 12 add 10 <* det er et navn med space foran *>
and ra(1) = textra(1)
and (if lg = 2 then ra(2) = textra(2) else true) then
begin
fpnr := fpnr + 1;
if system(4, fpnr, ra) = 8 shift 12 + 10 <* punktum med en tekst efter *> then
begin
if ra(1) = real <:yes:> or ra(1) = real <:ja:> then
boo := true
else
if ra(1) = real <:no:> or ra(1) = real <:nej:> then
boo := false
else
fpfejl(1);
l{sfpboo := true;
end
else
fpfejl(4);
end
else
fpnr := fpnr + 1;
end;
end l{sfpboo;
end;
l{sfpelsk = algol
external
\f
long procedure l{s_fp_el_sk(fptxt,sk{rmtxt);
string fptxt,sk{rmtxt;
begin
long tal;
tal:=l{sfptal(fptxt);
if tal=0 then
begin
tal:=indl{stal(sk{rmtxt);
end;
l{s_fp_el_sk:=tal;
end;
end;
l{sfptalf|l = algol
external
boolean procedure l{s_fp_talf|lge(text,tab);
string text;
integer array tab <*(1:max)*>;
begin
real array ra, textra(1:2);
integer i,j,fpnr,lg;
boolean fundet;
fundet := false;
lg := movestring(textra,1,text);
fpnr := 1;
l{s_fp_talf|lge := false;
for j:=system(4,fpnr,ra) while j<>0 and -, fundet do
begin
if j = 4 shift 12 add 10 and
ra(1) = textra(1) and
(if lg = 2 then ra(2) = textra(2) else true)
then
begin
i:=1;
l{s_fp_talf|lge := true;
for fpnr := fpnr + 1 while system(4,fpnr,ra) =
8 shift 12 + 4
do tab(increase(i)) := ra(1);
fundet := true;
end
else
fpnr := fpnr + 1;
end;
end;
end;
l{sfptext = algol
external
\f
boolean procedure l{s_fp_text(text,navn);
string text;
array navn <*(1:2)*>;
begin
real array ra, textra(1:2);
integer j, fpnr, lg;
boolean fundet;
fundet := false;
lg := movestring(textra,1,text);
fpnr := 1;
l{s_fp_text := false;
for j:= system(4,fpnr,ra) while j<>0 and -, fundet do
begin
if j = 4 shift 12 add 10 and
ra(1) = textra(1) and
(if lg = 2 then ra(2) = textra(2) else true )
then
begin
fpnr := fpnr + 1;
if system(4,fpnr,ra) = 8 shift 12 + 10 then
tofrom(navn,ra,8)
else
fpfejl(1);
l{s_fp_text := true;
fundet := true;
end
else
fpnr := fpnr + 1;
end;
end;
end;
renameentry = algol
external
boolean procedure rename_entry(oldname,newname);
real array oldname,newname;
begin
<* proceduren omd|ber (renamer) disc-filen 'oldname' til 'newname' *>
<* hvis 'oldname' ikke findes i forvejen oprettes en ny fil med navnet *>
<* 'newname' . resultatet af proceduren er true hvis det er g}et godt *>
<* ellers false *>
integer array ia(1:4);
zone z(128,1,stderror);
integer i,j;
ia(1) :=newname(1) shift(-24) extract(24);
ia(2) :=newname(1) extract(24);
ia(3) :=newname(2) shift(-24) extract(24);
ia(4) :=newname(2) extract(24);
i:=0;j:=1;
connectdoc(z,string oldname(increase(j)),21);
j := monitor(46)rename_entry:(z,i,ia);
close(z,true);
rename_entry := j=0;
end rename_entry;
end;
getexactpos = algol
external
\f
procedure getexactposition(z,block,rel,pwfree);
<*********************************************>
zone z;
integer block,rel,pwfree;
begin
comment proceduren finder den n|jagtige position
p} dokumentet tilknyttet z;
integer array
_ zdescr(1:20);
getzone6(z,zdescr);
block:=zdescr(9);
rel:=zdescr(14)+zdescr(16)-zdescr(19)-4*zdescr(20)//zdescr(18)*(zdescr(17)-1);
pwfree:=if zdescr(13) = 6 then zdescr(11) else zdescr(12);
end procedure getexactposition;
end;
setexactpos = algol
external
procedure setexactposition(z,block,rel,pwfree);
<*********************************************>
zone z;
integer block,rel,pwfree;
begin
integer array
_ zdescr(1:20);
integer
_ actblock,
_ zstate;
boolean input;
getzone6(z,zdescr);
actblock:=zdescr(9);
zstate:=zdescr(13);
input := zstate = 1 or zstate = 5;
if actblock = block and zstate <> 0 then
zdescr(14):=rel+zdescr(19)+4*zdescr(20)//zdescr(18)*(zdescr(17)-1)
else
begin
setposition(z,0,block - (if input then 1 else 0));
inrec6(z,0);
zdescr(9):=block;
zdescr(13):=zstate;
zdescr(14):=rel+zdescr(19);
zdescr(15):=zdescr(19)+4*zdescr(20)//zdescr(18);
zdescr(17):=1;
end;
zdescr(11):=zdescr(12):=pwfree;
zdescr(16):=0;
setzone6(z,zdescr);
end procedure setexactposition;
end;
copyproc = algol list.yes
external
integer procedure copyproc(zud, indnavn, slet_ind);
value slet_ind;
zone zud;
real array indnavn;
boolean slet_ind;
begin
long array buf(1:129);
integer array kind(1:128), alfabet(0:127);
integer j, segmnr;
zone zind(2*128, 2, stderror);
for j := 1 step 1 until 126 do
alfabet(j) := 6 shift 12 add j;
for j := 0, 127 do
alfabet(j) := 0 shift 12 add j;
alfabet(25) := 8 shift 12 add 25;
intable(alfabet);
j := 1;
connect_doc(zind, string indnavn(increase(j)), 0);
segmnr := 0;
buf(129) := extend 0;
for j := readall(zind, buf, kind, 1) while j <= 0 do
begin
repeatchar(zind);
write(zud, buf);
segmnr := segmnr + 1;
end;
copyproc := segmnr * 768 + write(zud, buf);
close(zind, true);
if slet_ind then
remove_entry(indnavn);
end;
end
«eof»