|
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: 15360 (0x3c00)
Types: TextFile
Names: »tfpread«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦this⟧ »tfpread«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦e4d872f9f⟧ »cproc«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦e4d872f9f⟧ »cproc«
└─⟦this⟧
;copyright Anders Lindgård, october 1980;
mode list.yes
lookup fpalglist
if ok.yes
mode listing.yes
fpreadlib=edit
i/
initfp takefpitem programname readifpnext readsfpnext readlsfp,
readinfp readbfp readifp readrfp readsfp connectlso connectinp,
cutcloseout,
fpbooleans fpcommand fpin fpinareas fpints fpitems fplist fpnr,
fpout fpreals fptestpr fptexts fpunstacki
/,f
fplc=edit fpreadlib
i/
lkjh=lookup,
/,l b,s1,i/
if ok.yes
(
scope temp,
/,l b,s1,i/
clear temp,
/,l b,i/
)
/,f
i fplc
fpbooleans =set bs initfp 17 576.0 0 4.0 1.26
fpcommand =set bs initfp 9 512.0 0 4.0 1.26
fpin =set bs initfp 1 512.0 0 4.0 1.26
fpinareas =set bs initfp 15 576.0 0 4.0 1.26
fpints =set bs initfp 19 576.0 0 4.0 1.26
fpitems =set bs initfp 13 576.0 0 4.0 1.26
fplist =set bs initfp 3 512.0 0 4.0 1.26
fpnr =set bs initfp 25 576.0 0 4.0 1.26
fpout =set bs initfp 7 512.0 0 4.0 1.26
fpreals =set bs initfp 21 576.0 0 4.0 1.26
fptestpr =set bs initfp 11 512.0 0 4.0 1.26
fptexts =set bs initfp 23 576.0 0 4.0 1.26
fpunstacki =set bs initfp 5 512.0 0 4.0 1.26
takefpitem=set 14
takefpitem=algol
general procedure for scanning fpparameters
8 3 76
external
boolean procedure takefpitem(text,type,nr,A);
value type;
string text;
integer type,nr;
array A;
begin
own integer c,inareas;
own boolean first;
integer i,j,sep,nsep,item,nitem,itc;
array mt,a,na(1:2);
procedure readnext(no);
integer no;
begin
integer i;
sep:=nsep;
item:=nitem;
for i:=1,2 do a(i):=na(i);
nsep:=system(4,no,na);
nitem:=nsep extract 12;
nsep:=nsep shift (-12);
if no=0 and (nsep=0 or nsep=2) then nsep:=4;
fpnr:=no;
end readnext;
if -,first or fplist then begin
boolean nl,ls;
integer fpcas,chars,v;
inareas:=c:=0;
fpitems:=fpinareas:=fpbooleans:=fpints:=fpreals:=
fptexts:=fpnr:=0;
ls:=false;
nl:=fpcommand:=true;
if fplist then write(out,<:<10>:>);
nitem:=item:=fpcas:=c:=-1; nsep:=4;
chars:=0;
for c:=c+1 while nsep>=4 do
begin
readnext(c);
if fplist then begin
if nsep>0 then begin
if -,nl then chars:=chars+
write(out,case nsep//2 of(<:<10>:>,<: :>,<:=:>,<:.:>));
nl:=false;
if nsep=4 and chars>60 then begin chars:=0;
write(out,<:,<10>:>); end;
i:=1;
if nitem=4 then chars:=chars+
write(out,<<d>,round(na(1))) else
if nitem=10 then chars:=chars+
write(out,string na(increase(i)));
end else if nsep=-2 then write(out,<:):>);
end;
if nsep=6 then ls:=true;
if sep=4 and nsep<=4 and item=10 then begin
inareas:=inareas+1;
fpcas:=6;
end else
if sep=4 and item=10 then fpcas:=0 else
if sep=8 and fpcas=0 then begin
if item=10 then begin
j:=i:=1;
fpcas:=2;
for i:=1 step 1 until 8 do begin
if a(1)=real (case i of(<:yes:>,<:no:>,<:ja:>,<:nej:>,
<:true:>,<:false:>,<:sand:>,<:falsk:>)) then fpcas:=7;
end for loop;
if fpcas=7 then fpbooleans:=fpbooleans+1 else
fptexts:=fptexts+1;
end text.text or text.boolean else
if item=4 and nsep<=4 then begin
fpcas:=3; fpints:=fpints+1; end else
if item=4 and nsep=8 then fpcas:=4;
end .<int> or .<text>;
if item=4 and sep=8 and fpcas=4 then begin
fpcas:=5; fpreals:=fpreals+1;
end;
end loop;
if inareas>0 and -,ls then inareas:=inareas-1;
fpinareas:=inareas;
if ls then begin v:=1; fpout:=true; end else v:=0;
if inareas>0 and c>=1+v then begin
readnext(1+v);
readnext(2+v);
if sep=4 and item=10 and nsep<=4 then fpin:=true;
if fpin and fpunstacki then unstackcuri
end RSstackcuri;
fpitems:=fpbooleans+fpints+fpreals+fptexts+fpinareas;
fplist:=false;
first:=true;
end first;
takefpitem:=type=0 and (fpout or fpitems>0);
if type>1 and type<6 then begin
mt(2):=0.0 shift(-12);
movestring(mt,1,text);
if fptestpr then begin
i:=1;
write(out,<:<10>:>,text,<:? :>,string mt(increase(i)));
end;
end;
if type=0 then
begin
<*programname*>
readnext(if fpout then 1 else 0);
for i:=1,2 do A(i):=na(i);
takefpitem:=fpout or fpitems>0;
i:=1;
if fptestpr then write(out,<:<10>program name: :>,
string A(increase(i)));
end type=0;
if type=1 then begin
if fpout then begin
readnext(0);
for i:=1,2 do A(i):=na(i);
takefpitem:=true;
if fptestpr then write(out,<:<10>left side found:>);
end;
end else if type=2 and nr<=inareas then begin
takefpitem:=true;
i:=0;
itc:=if fpout then 1 else 0;
nsep:=0;
for itc:=itc+1 while itc<=c and i<=nr do begin
readnext(itc);
if sep=4 and nsep=4 then i:=i+1;
if i=nr then i:=i+1;
end;
for j:=1,2 do A(j):=a(j);
i:=1;
if fptestpr then write(out,<:<10>areaname :>,
string a(increase(i)));
end type=2 else if type>0 and type<6 then begin
comment find matching text;
itc:=if fpout then 1 else 0;
for itc:=itc+1 while itc<=c and
-,(sep=4 and nsep=8 and a(1)=mt(1) and a(2)=mt(2)) do
readnext(itc);
if itc<=c then begin
comment item found;
i:=1;
if fptestpr then write(out,<:<10>match :>);
if type=3 and nitem=10 then begin
takefpitem:=true;
j:=i:=1;
if fptestpr then write(out,<:text.text :>,
string a(increase(j)),<:.:>,
string na(increase(i)));
for i:=1,2 do A(i):=na(i) end else
if type>3 and nitem=4 then
begin
takefpitem:=true;
i:=1;
if fptestpr then write(out,<:text.int :>,
string a(increase(i)),<<d>,round na(1));
A(1):=na(1);
if type=5 then begin
readnext(itc);
if nsep=8 then A(2):=na(1) else A(2):=-1;
if A(2)>0 and fptestpr then write(out,<:.:>,<<d>,round na(1));
end;
end;
end;
end;
end;
end;
if warning.yes
end
initfp=set 1
initfp=algol
initfp
8 3 76
external boolean procedure initfp;
begin
array A(1:2);
initfp:=takefpitem(<::>,0,0,A);
initfp:=fpitems<>0;
end;
end;
if warning.yes
end
programname=set 1
programname=algol
external
procedure programname(name);
array name;
begin
boolean b;
b:=takefpitem(<::>,0,0,name);
if -,b then nameload(program-2,name);
end;
end;
readifpnext=set 1
readifpnext=algol
readifpnext
18 3 76
external boolean procedure readifpnext(no,int);
integer no,int;
begin integer sep,item;
boolean f;
array A(1:2);
no:=no+1;
sep:=system(4,no,A);
item:=sep extract 11;
sep:=sep shift (-12) extract 11;
readifpnext:=f:=sep=8 and item=4;
if f then int:=A(1);
end;
end;
if warning.yes
end
readsfpnext=set 1
readsfpnext=algol
readsfpnext
18 3 76
external boolean procedure readsfpnext(no,A);
integer no;
array A;
begin integer sep,item;
boolean f;
array B(1:2);
no:=no+1;
sep:=system(4,no,B);
item:=sep extract 12;
sep:=sep shift (-12) extract 11;
readsfpnext:=f:=sep=8 and item=10;
if f then begin
for sep:=1,2 do A(sep):=B(sep);
end;
end;
end;
r=set 40
lookup initfp
initfp=changeentry initfp initfp initfp initfp initfp initfp fplist
lookup initfp
readlsfp=set 1
readlsfp=algol
readlsfp
8 3 76
external boolean procedure readlsfp(output);
array output;
begin
readlsfp:=takefpitem(<::>,1,0,output);
end;
end;
readbfp=set 1
readbfp=algol
readbfp
8 3 76
external boolean procedure readbfp(text,b,initial);
value initial;
string text; boolean b,initial;
begin
array A(1:2); integer i,c; boolean f;
f:=readbfp:=takefpitem(text,3,0,A);
if f then begin
f:=false;
c:=0;
for i:=1,2,3,4 do begin
if A(1)=real
(case i of(<:yes:>,<:true:>,<:ja:>,<:sand:>)) then
begin c:=i; f:=b:=true end else
if A(1)=real
(case i of(<:no:>,<:false:>,<:nej:>,<:falsk:>)) then
begin c:=4+i; f:=true; b:=false; end;
end casei;
if -,f then readbfp:=false;
end item found;
if -,f then b:=initial;
end;
end;
readifp=set 1
readifp=algol
readifp
8 3 76
external boolean procedure readifp(text,int,initial);
value initial;
string text;
integer int,initial;
begin
boolean b;
array A(1:2);
b:=readifp:=takefpitem(text,4,0,A);
if b then int:=A(1) else int:=initial;
end;
end;
readrfp=set 2
readrfp=algol
readrfp
8 3 75
external
boolean procedure readrfp(text,val,initial);
value initial;
string text;
real val,initial;
begin
boolean b;
integer i;
real fak;
array A(1:2);
b:=readrfp:=takefpitem(text,5,0,A);
fak:=.1;
if b then begin
val:=A(1);
if A(2)>-1 then begin
if A(2)=0 then begin
fak:=fak*.1;
i:=0;
for fpnr:=fpnr while readifpnext(fpnr,i) and i=0 do fak:=.1*fak;
A(2):=i;
end;
if A(2)<>0 then
val:=val+fak*A(2)*10**(-entier(ln(A(2))/ln(10)));
end;
end else val:=initial;
end;
end;
readsfp=set 1
readsfp=algol
readsfp
11 3 76
external boolean procedure readsfp(text,TXT,initial);
string text,initial;
array TXT;
begin
boolean b;
b:=readsfp:=takefpitem(text,3,0,TXT);
if -,b then movestring(TXT,1,initial);
end;
end;
readinfp=set 1
readinfp=algol
readinfp
11 3 76
external boolean procedure readinfp(input,nr);
value nr;
array input;
integer nr;
readinfp:=takefpitem(<::>,2,nr,input);
end;
connectlso=set 3
connectlso=algol
connectlso
1978 10 27
external
boolean procedure connectlso;
begin
integer res,i;
integer array tail(1:10);
array field aux;
array output(1:2);
aux:=2;
connectlso:=false;
if readlsfp(output) then
begin
res:=lookuptail(output,tail);
if res=3 then
begin
cleararray(tail);
tail(1):=25;
res:=createentry(output,tail);
end unknown;
if tail(1)>0 then
begin
scope_user(output);
permentry(output,2);
end bsarea;
res:=connectcuro(output);
if res <>0 then
begin
i:=1;
unstackcuro;
alarm(<:***connect left side :>,string output(increase(i)),
<: connect result :>,res);
end else
begin
connectlso:=true;
if tail(1)<0 and tail(1) extract 12=12 then
begin
comment punch;
write(out,false,100);
end punch;
setposition(out,tail(7),tail(8));
end;
end;
end;
end;
connectinp=set 3
connectinp=algol
connectinp
1978 10 27
1978-09-13
external
boolean procedure connectinp(nr);
value nr; integer nr;
begin
integer i,res1,res2;
integer array tail(1:10);
array input(1:2);
res1:=if readinfp(input,nr) then lookuptail(input,tail) else 1;
connectinp:=true;
res2:=connectcuri(input);
if res1<>0 or res2<>0 then
begin
unstackcuri;
i:=1;
alarm(<:***connect input :>,string input(increase(i)),
if res1<>0 then <: not found in parameterlist :> else <: connect result :>,
if res1<>0 then nr else res2);
connectinp:=false;
end setposition(in,tail(7),tail(8));
end;
end;
cutcloseout=set 4
cutcloseout=algol
1980-11-11
external procedure cutcloseout;
if fpout then
begin
integer shcl,i,j,res,ch,char,s;
integer array zd(1:20),t(1:10);
array name(1:2);
array field nf;
long array field lo;
lo:=0;
getzone6(out,zd);
nf:=2;
for i:=1,2 do name(i):=zd.nf(i);
res:=lookuptail(name,t);
closeout;
if res<>0 then alarm("nl",1,"*",3,name.lo,<: does not exist:>);
if t(1)>0 then
begin
res:=connectcuri(name);
char:=ch:=0;
repeat ch:=ch+1;
res:=readchar(in,char);
until char=25;
s:=(ch+767)//768;
t(1):=s;
shcl:=t(6):=systime(7,0,0.0);
t(7):=t(8):=t(9):=t(10):=0;
res:=changetail(name,t);
if res<>0 then write(out,"nl",2,"*",2,name.lo,<: changeentry :>,
res,t(1));
end t(1)>0;
end;
end;
scopelib=edit fpreadlib
i/
global,
/,f
compr=edit fpreadlib
r/initfp/initfp=compresslib/,l1,r/,//,l1,s,f
i compr
if 10.no
i scopelib
looklib=edit fpreadlib
i/
lookup,
/,f
i looklib
testfp=set 60
scope login testfp
testfp=algol
testprogram for fp-parameter reading procedures
begin
integer points,degree,i,inr,res;
boolean fit;
real w;
array input,output,ident(1:2);
fplist:=true;
initfp;
outendcur(0);
if readlsfp(output) then begin
res:=connectcuro(output);
i:=1;
if res<>0 then begin
unstackcuro;
alarm(<:***connect output :>,string output(increase(i)),res);
end;
end;
write(out,<:<10>items,boo,int,real,text,inarea:>,
fpitems,fpbooleans,fpints,fpreals,fptexts,fpinareas);
if fpin then write(out,<:<10>input:>);
if fpout then write(out,<:<10>fpoutput:>);
if readbfp(<:fit:>,fit,true) then write(out,<:<10>fit found :>,
if fit then <:yes:> else <:no:>);
if readifp(<:degree:>,degree,3) then
write(out,<:<10>degree =:>,degree);
if readifp(<:points:>,points,20) then
write(out,<:<10>points =:>,points);
if readrfp(<:weight:>,w,1.0) then
write(out,<:<10>w =:>,w);
i:=1;
if readsfp(<:ident:>,ident,<::>) then
write(out,<:<10>ident found :>,string ident(increase(i)));
for inr:=1 step 1 until fpinareas do begin
readinfp(input,inr);
i:=1;
write(out,<:<10>input:>,inr,<: = :>,string input(increase(i)));
end;
outendcur(10);
if fpout then closeout;
end;
if warning.no
(
fptestt=set 5
fptestt=testfp fptestt list.yes fit.no degree.12 fgh.9 4.4
c=copy message.no fptestt
testfp weight.0
testfp weight.1.0.5
testfp weight.2.0.0.527
testfp weight.0.0.0.0.3
testfp fptestt testfp weight.3.9
testfp f.f fit.no degree.7
)
testfp=algol
testprogram for fp-parameter reading procedures
begin
integer points,degree,i,inr,res;
boolean fit;
real w;
array ident(1:2);
fplist:=true;
initfp;
outendcur(0);
connectlso;
write(out,<:<10>items,boo,int,real,text,inarea:>,
fpitems,fpbooleans,fpints,fpreals,fptexts,fpinareas);
if fpin then write(out,<:<10>input:>);
if fpout then write(out,<:<10>fpoutput:>);
if readbfp(<:fit:>,fit,true) then write(out,<:<10>fit found :>,
if fit then <:yes:> else <:no:>);
if readifp(<:degree:>,degree,3) then
write(out,<:<10>degree =:>,degree);
if readifp(<:points:>,points,20) then
write(out,<:<10>points =:>,points);
if readrfp(<:weight:>,w,1.0) then
write(out,<:<10>w =:>,w);
i:=1;
if readsfp(<:ident:>,ident,<::>) then
write(out,<:<10>ident found :>,string ident(increase(i)));
for inr:=1 step 1 until fpinareas do begin
connectinp(inr);
comment read input files;
unstackcuri;
end;
outendcur(10);
if fpout then closeout;
end;
if warning.no
(
fptestt=set 5
fptestt=testfp fptestt list.yes fit.no degree.12 fgh.9 4.4
c=copy message.no fptestt
testfp weight.0
testfp weight.1.0.5
testfp weight.2.0.0.527
testfp weight.0.0.0.0.3
testfp fptestt testfp weight.3.9
testfp f.f fit.no degree.7
)
testrs=set 6
testrs=algol
begin
integer i;
array n(1:2);
fptestpr:=true;
if readsfp(<:t:>,n,<::>) then write(out,<: text:>);
if readifp(<:t:>,i,1) then write(out,<: int:>);
end;
testrs t.5
testrs t.pli
testname=algol
begin
array a(1:2);
programname(a);
write(out,string inc(a));
end
testn1=assign testname
testn1 l.l
testname l.l
testn1
testname
mode list.no
▶EOF◀