|
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: 51456 (0xc900)
Types: TextFile
Names: »rofftxt«
└─⟦2c55ea56f⟧ Bits:30001844 SW-save af projekt 1000, Alarm-system
└─⟦093e2ad1c⟧
└─⟦this⟧ »rofftxt«
job j 1 time 11 0 perm disc1 1000 10
roff=set 1 disc1
scope user roff
roff=algol
begin
\f
<***************************************************************
*
* R O F F T E X T F O R M A T T E R
*
* The ROFF text formatter is capable of rearranging a source
* text for e.g. a manual into lines of equal length with a
* straight right margin, breaking the text into pages, numbering
* the pages and chapters automatically etc.
*
* Tutorial guide (danish): RCSL no. 52-AA 1036
*
* ROFF was programmed in feb. 1981 by ERK and STB
*
* Maintenance feb. 1981 - xx by STB
*
**************************************************************>
\f
<********* external procedures *****************
connect_bs,
læs_fp_boo,
text_close,
text_open
*>
\f
integer procedure enterpage(ix);
integer ix; <* also result param *>
begin
integer i,ci,last_partition_possibility;
last_partition_possibility:=0;
ci:=page(li,-1) extract 8;
if ci<>(page(li,-2) extract 8) then
begin
ci:=ci+1;
page(li,ci):="sp";
if join then
begin <* join this line to the previous without space *>
ci:=ci-1;
join:=false;
end join;
end;
i:=ix;
wordstart(noofwords+1):=ci+1;
while kind(i)=chartype and ci<=ll do
begin
if val(i)=hyphenation_char then
begin
if ci<ll then
last_partition_possibility:=ci+1
end
else
begin
if (val(i)='-') and (ci<ll) then last_partition_possibility:=ci+1;
ci:=ci+1;
page(li,ci):=false add (val(i) add (charmode shift 8));
end;
i:=i+1;
end;
if ci>ll then
begin <* word exceeds line boundary *>
page(li,ci):="sp";
if last_partition_possibility>wordstart(no_of_words+1) then
begin <* insert hyphenation and part the word *>
page(li,last_partition_possibility):="-";
enterpage:=0;
ix:=i-(ci-last_partition_possibility+1);
if val(ix)='-' then ix:=ix+1;
noofwords:=noofwords+1;
page(li,-1):=false add last_partition_possibility;
end
else <* no possibility for partition *>
enterpage:=1;
end
else
begin
enterpage:=0;
ix:=i; <* next free input char *>
page(li,-1):=false add ci; <* last used position in line *>
noofwords:=noofwords+1;
end;
end enterpage;
\f
procedure changeline(nobreak,no);
value nobreak,no; boolean nobreak; integer no;
begin integer i;
boolean error;
no:=spacing*no;
join:=false;
error:=false;
if bosslinemode then
begin
bossline(li):=bosslineno;
if fill and (-,nobreak) and normalline then
<* decrement bosslineno *>
bossline(li):=bossline(li)-10;
end bosslinemode;
if no<=0 then
begin
if (page(li,-2) extract 8)=(page(li,-1) extract 8) then
begin
page(li,-2):=page(li,-1):=false add indents;
cleartemps;
error:=true;
end else no:=1;
end;
if -, error then
begin
if (noofwords>1) and rightjust and nobreak then
rightjustify(li,noofwords);
if frame then
begin <* make vertical lines *>
for i:=first_frame_pos step 1 until last_frame_pos do
if frame_pos(i) then
begin
if (page(li,i) extract 8 = 'sp' ) or (page(li,i) extract 8 =spch) then
page(li,i):="!"
else
errmess(<:frame overwrites char:>,pi,li);
end;
if first_frame_pos-1<page(li,-2) extract 8 then
page(li,-2):=false add (first_frame_pos-1);
if last_frame_pos>page(li,-1) extract 8 then
page(li,-1):= false add last_frame_pos;
end;
noofwords:=0;
if ((pl-(tm+bm))-(li+no))>=0 then
begin
page(li,0):=false add ((no shift 4) add special);
li:=li+no;
end
else
begin
page(li,0):=false add ((spacing shift 4) add special);
li:=li+spacing;
outputpage(1);
end;
if frame then
for i:=first_frame_pos step 1 until last_frame_pos do
page(li,i):="sp";
page(li,-2):=page(li,-1):=false add indents;
cleartemps;
if special>3 or charmode=0 then special:=0;
end not error;
end changeline;
\f
procedure outputpage(no);
value no; integer no;
begin
integer i,j,x,y,ch,centerspaces;
if (li=1) and (page(li,-2)==page(li,-1)) then
<* do nothing, page already flipped *>
else
begin
if (pi>=first_page) and (pi<=last_page) then
begin <* write *>
outputtoppage;
i:=1;
while i<li do
begin
if lineno then write(zout,<<dddd>,i);
x:=page(i,-2) extract 8; y:=page(i,-1) extract 8;
special:=page(i,0) extract 4;
if special<>0 then
begin
case special of
begin
begin <* underline word(s) *>
write(zout,"sp",po+x);
for j:=x+1 step 1 until y do
if ((page(i,j) shift (-8)) extract 4)=1 then
outchar(zout,95) else outchar(zout,'sp');
outchar(zout,carriage extract 8);
if lineno then write(zout,"sp",4);
end;
begin <* overprint word(s) *>
end;
begin <* overprint and underline word(s) *>
end;
begin <* center line *>
centerspaces:=(ll-(indents+(y-x)))//2;
write(zout,"sp",centerspaces);
end;
end case;
end;
write(zout,"sp",po+x);
for j:=x+1 step 1 until y do
begin
ch:=page(i,j) extract 8;
if ch=spch then ch:='sp';
outchar(zout,ch);
end;
if bosslinemode then
begin <* write the corresponding bosslineno. *>
write(zout,"sp",stdll+10-j-(if special=4 then centerspaces else 0), bossline(i));
end bosslinemode;
x:=(page (i,0) shift (-4)) extract 8;
write(zout,carriage,1,"nl",1);
if (x>1) and (lineno or bosslinemode) then
begin
for j:=i+1 step 1 until i+x-1 do
begin <* write linenos or bosslines *>
if lineno then write(zout,<<dddd>,j)
else write(zout,"sp",4);
if bosslinemode then
write(zout,"sp",po+stdll+9, bossline(i));
outchar(zout,'nl');
end
end
else
write(zout,"nl",x-1);
i:=i+x;
end i loop;
outputbottompage;
end write;
pi:=pi+1;
end flip one page;
for i:=2 step 1 until no do
begin
if (pi>=first_page) and (pi<=last_page) then
begin
outchar(zout,form_f extract 8);
if lineno then write(zout,<<dddd>,pi);
outputtoppage;
outputbottompage;
end;
pi:=pi+1;
end;
li:=1;
page(li,-2):=page(li,-1):=false add indents;
cleartemps;
end outputpage;
\f
procedure outputtoppage;
begin integer i;
if header then
begin
i:=head(1,0) extract 8;
if i<>0 then writeno(pi,head,i,1,pnof);
outchar(zout,'nl');
write(zout,"sp",po);
for i:=1 step 1 until stdll do outchar(zout,head(1,i) extract 8);
write(zout,"nl",tm-1);
end
else write(zout,"nl",tm);
end otp;
\f
procedure outputbottompage;
begin integer i;
if footer then
begin
i:=foot(1,0) extract 8;
if i<>0 then writeno(pi,foot,i,1,pnof);
write(zout,"nl",(pl-(tm-1))-li,"sp",po);
for i:=1 step 1 until stdll do outchar(zout,foot(1,i) extract 8);
end;
write(zout,"nl",1,form_f,1);
end obp;
\f
procedure writecontents(lindex,no,etx,pindex,level);
value lindex,no,etx,pindex,level;
integer lindex,no,etx,pindex,level;
begin
boolean array pageno(1:1,1:pnof);
integer i,ix,lix,inden;
lix:=if level=1 then 2 else 1;
if ((contli+lix>pl) and level>1) or ((contli+lix+3)>pl and level=1) then
begin
contpi:=contpi+1;
outchar(contents,form_f extract 8);
write(contents,"nl",1,"sp",(stdll//2)+po);
write(contents, (case contpi of
_ (<:i:>,<:ii:>,<:iii:>,<:iv:>,<:v:>,
_ <:vi:>,<:vii:>,<:viii:>,<:ix:>,<:x:>)),"nl",2);
if english then
write(contents,"sp",po,<:CONTENTS:>,"sp",stdll-8,<:PAGE:>,
_ carriage,1, "sp",po, false add 95,stdll+4, "nl",2)
else
write(contents,"sp",po,<:INDHOLD:>,"sp",stdll-7,<:SIDE:>,
_ carriage,1, "sp",po, false add 95,stdll+4, "nl",2);
contli:=4;
end else
begin
contli:=contli+1;
write(contents,"nl",lix);
end;
ix:=1;
writeno(pindex,pageno,ix,1,pnof);
inden:= case level of (0,4,9,16);
write(contents,"sp",inden+po);
for i:=1 step 1 until no do outchar(contents,page(lindex,i) extract 8);
outchar(contents,'sp');
outchar(contents,'sp');
for i:=stdindent+1 step 1 until etx do outchar(contents,page(lindex,i) extract 8);
write(contents,".",stdll-((etx-stdindent+1)+no+inden));
for i:=1 step 1 until pnof do outchar(contents,pageno(1,i) extract 8);
end writec;
\f
procedure pushindent(no);
value no; integer no;
begin integer x;
while instack(0)<>0 do popindent; <* empty stack *>
x:=instack(0)+1;
if x>10 then errmess(<:indent level exceeds 10:>,pi,li)
else
begin
instack(x):=indents;
indents:=indents+no;
instack(0):=x;
end;
end pi;
\f
procedure popindent;
begin integer x;
x:=instack(0);
if x>0 then
begin
indents:=instack(x);
instack(0):=x-1;
end;
end popi;
\f
procedure settempindent(no);
value no; integer no;
begin
tempindent:=no;
indents:=indents+tempindent;
end sti;
\f
procedure moveuntouched(ix);
value ix; integer ix;
begin
integer ci;
ci:=page(li,-1) extract 8;
while kind(ix)<>8 and ci<=stdll+7 do
begin
ci:=ci+1;
if kind(ix)=tabtype then
begin
page(li,-1):=false add (ci-1);
testout(<:moveunt., bef. tab, p(-1)=:>,page(li,-1) extract 8);
tabulate(ix);
ci:=(page(li,-1) extract 8) ;
end else
begin
page(li,ci):=false add (val(ix) add (charmode shift 8));
ix:=ix+1;
end;
end;
if ci>stdll+7 then errmess(<:no fill line exceeds page boundary:>,pi,li);
page(li,-1):=false add ci;
end moveuntouched;
\f
integer procedure readoneparam(ix);
integer ix;
begin
integer sign,p1;
sign:=1; p1:=0;
while kind(ix)=7 do ix:=ix+1;
if val(ix)='+' or val(ix)='-' then
begin
sign:=if val(ix)='+' then 1 else -1;
ix:=ix+1;
end;
while val(ix)<='9' and val(ix)>='0' do
begin
p1:=p1*10+(val(ix)-'0');
ix:=ix+1;
end;
p1:=p1*sign;
readoneparam:=p1;
end rop;
\f
procedure cleartemps;
begin
indents:=indents-tempindent;
tempindent:=0;
end ct;
\f
procedure errmess(s,pi,li);
string s; integer pi,li;
begin
if mess then
write(out,<:<10>page: :>,<<dd>,pi,<:, line: :>,li);
if bosslinemode then
write(out,<:, bossline: :>,<<ddddd>,bosslineno,":",1,"sp",1,s);
end err;
\f
procedure writeno(x,resarray,resix,lix,nowidth);
value x,lix,nowidth; integer x,resix,lix,nowidth;
boolean array resarray;
begin integer ix,i; integer array temp(1:10);
ix:=0;
while x<>0 do
begin
ix:=ix+1;
temp(ix):=x mod 10;
x:=x//10;
end;
for i:=1 step 1 until (nowidth-ix) do
begin
resarray(lix,resix):="sp";
resix:=resix+1;
end;
while ix>0 do
begin
resarray(lix,resix):=false add (temp(ix)+'0');
ix:=ix-1;
resix:=resix+1;
end;
end writeno;
\f
procedure tabulate(inputix);
integer inputix;
begin
integer ix,tabix,wix,wordwidth,tabwidth,i;
boolean error;
error:=false;
repeat <* until no more consequtive tabs *>
tabix:=ix:=(page(li,-1) extract 8)+1;
while -, tab(1,tabix) and tabix<=ll do tabix:=tabix+1;
if tabix>ll then
begin
errmess(<:tabulation exceeds line:>, pi,li);
changeline(false,0);
inputix:=inputix+1;
error:=true;
end
else
begin
<* tabix points to the next tab pos
_ ix points to the first free pos in the line *>
if (tab(2,tabix) extract 8)=1 then <* tabulate and left justify *>
begin
for i:=ix step 1 until tabix-1 do page(li,i):="sp";
ix:=tabix;
if test then testout(<:tab left, ix=:>,ix);
end else
begin <* right or centre tab *>
wix:=inputix+1;
while kind(wix)=chartype do wix:=wix+1;
wordwidth:=wix-inputix-1;
tabwidth:=tabix-ix+1;
if (tab(2,tabix) extract 8)=3 then <* tabulate and centre word *>
wordwidth:=wordwidth//2+1;
if test then testout(<:tab c-r, wordwidth=:>,wordwidth);
if test then testout(<:tab c-r, tabwidth =:>,tabwidth);
if wordwidth>tabwidth then
begin
errmess(<:C or R tabulation exceeds available room:>,pi,li);
inputix:=inputix+1;
error:=true;
end
else
for i:=1 step 1 until tabwidth-wordwidth do
begin
page(li,ix):="sp";
ix:=ix+1;
end;
end;
<* ix points to the first free pos in the line *>
if -,error then
begin
page(li,-1):=false add (ix-1);
inputix:=inputix+1;
if kind(inputix)=tabtype then
begin
page(li,ix):="sp";
ix:=ix+1;
page(li,-1):=false add (ix-1);
end;
\f
end not error;
end not error;
until (kind(inputix)<>tabtype) or error;
end tabulate;
\f
procedure testout(s,i);
value i; integer i; string s;
if test then
begin <* write testoutput on current output *>
write(out,"nl",1,s,"sp",1,i);
setposition(out,0,0);
end testout;
\f
procedure rightjustify(lineno,noofwords);
value lineno, noofwords;
integer lineno,noofwords;
begin
<* the procedure stuffs extra spaces between words on a given line within
_ the page, thus right justifying the right margin.
_ the algorithm used is found in
_ " a data directed approach to program design",
_ software practice and experience, vol. 10, 1980.
*>
integer extrablanks,rightblanks,leftblanks,intersectword,i,wordno,spaces,
_ newchpt,oldchpt,lineno1;
extrablanks:=ll-page(lineno,-1)extract 8;
if extrablanks<>0 then
begin
<* compute leftblanks, rightblanks, and intersectword *>
lineno1:= if spacing mod 2 = 0 then lineno//2 else lineno;
<* because otherwise we would always justify to the
same side if spacing were e.g. 2 *>
if lineno1 mod 2=0 then
begin <* justify left line *>
rightblanks:=(extrablanks)//(noofwords-1)+1;
leftblanks := rightblanks+1;
intersectword:=(extrablanks mod (noofwords-1))+1;
end else
begin <* justify right line *>
leftblanks:=(extrablanks)//(noofwords-1)+1;
rightblanks:=leftblanks+1;
intersectword:=noofwords-(extrablanks mod (noofwords-1));
end;
newchpt:=ll+1; oldchpt:=page(lineno,-1) extract 8 +1;
for wordno:=noofwords step -1 until 2 do
begin <* move word forward and insert spaces to the left *>
repeat
newchpt:=newchpt-1;
oldchpt:=oldchpt-1;
page(lineno,newchpt):=page(lineno,oldchpt);
until oldchpt=wordstart(wordno);
oldchpt:=oldchpt-1;
spaces:=if wordno>intersectword then rightblanks else leftblanks;
for i:=1 step 1 until spaces do
begin
newchpt:=newchpt-1;
page(lineno,newchpt):="sp";
end;
end move word;
page(lineno,-1):=false add ll;
end extrab<>0;
end right just;
\f
procedure initall;
begin
boolean boo;
real array ra(1:2);
text_open(zout);
begin long array l1,l2(1:2);
l1(1):=long <:conte:>+'n'; l1(2):=long <:ts:>;
l2(1):=long <:user:>;
i:=connect_bs(contents,l1,1,l2,0);
if i<>0 then system(9,0,<:cannot open contents:>);
end;
setposition(contents,0,0);
qume:=false;
læsfpboo(<:qume:>,qume);
if qume then
begin
form_f:=false add (128+'ff');
carriage:=false add (128+'cr');
end else
begin
form_f:="ff";
carriage:="cr";
end;
english:=false;
læsfpboo(<:english:>,english);
clock:=false;
læsfpboo(<:clock:>,clock);
lineno:=false;
læsfpboo(<:lineno:>,lineno);
clevel:=læsfptal(<:level:>);
if clevel=0 then clevel:=4;
test:=false;
test:=læsfpboo(<:test:>,test);
bosslinemode:=false;
bosslineno:=0;
læsfpboo(<:bosslines:>,bosslinemode);
læsfpboo(<:bl:>, bosslinemode);
mess:=true;
læsfpboo(<:mess:>,mess);
læsfpboo(<:message:>,mess);
læsfpboo(<:ms:>,mess);
first_page:=læsfptal(<:first:>);
last_page:=læsfptal(<:last:>);
if last_page=0 then last_page:=1000000;
for i:=0 step 1 until 127 do table(i):=
(case i+1 of ( 0, 0, 0, 0, 0, 0, 0, 0,
<* ht,nl,ff*> 0,10, 8, 0, 8, 0, 0, 0,
______________ 0, 0, 0, 0, 0, 0, 0, 0,
<* em *> 0, 8, 0, 0, 0, 0, 0, 0,
<* sp *> 7,10, 9, 9, 9, 9, 9, 9,
<*: ; -.*> 9, 9, 9, 9, 9, 9, 9, 9,
<*0...*> 9, 9, 9, 9, 9, 9, 9, 9,
<*:;?*> 9, 9, 9, 9, 9, 9, 9, 9,
<* @ A..*> 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
______________ 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
______________ 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
______________ 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0))
shift 12 +i;
for i:=32 step 1 until 126 do
for j:=32 step 1 until 126 do action(i,j):=false add 0;
for i:=1,2 do
for j:=1 step 1 until 100 do tab(i,j):=false;
for i:=1 step 1 until 100 do framepos(i):=false;
first_frame_pos:=last_frame_pos:=1;
inix:=1;
figno:=exno:=0;
li:=1;
pi:=1;
stdindent:=8;
stdll:=66;
ll:=stdll-5;
pl:=60;
tm:=5;
bm:=5;
pnof:=3;
sptype:=7;
chartype:=9;
tabtype:=10;
po:=8;
indents:=stdindent;
special:=0;
charmode:=0;
spacing:=1;
blkch:='-';
spch:='@';
hyphenation_char:='_';
tabch:='!';
comch:='>';
rightjust:=true;
noofwords:=0;
fill:=true;
contpi:=0;
contli:=10000;
inputend:=lineend:=false;
appendix:=false;
frame:=false;
join:=false;
footer:=false;
header:=true;
for i:=1 step 1 until 100 do head(1,i):=foot(1,i):="sp";
foot(1,0):=false add 0;
head(1,0):=false add (stdll//2 - 1);
for i:=1 step 1 until 5 do aix(1):=0;
inlno:=0;
tempindent:=0;
instack(0):=0;
intable(table);
page(li,-2):=page(li,-1):=false add indents;
page(li,0):=false;
action('s','p'):=false add 1;
action('c','c'):=false add 2;
action('c','e'):=false add 3;
action('t','m'):=false add 4;
action('b','m'):=false add 5;
action('u','l'):=false add 6;
action('i','n'):=false add 7;
action('t','i'):=false add 8;
action('f','i'):=false add 9;
action('n','f'):=false add 10;
action('n','p'):=false add 11;
action('p','o'):=false add 12;
action('a','1'):=false add 13;
action('a','2'):=false add 14;
action('a','3'):=false add 15;
action('a','4'):=false add 16;
action('h','e'):=false add 17;
action('f','o'):=false add 18;
action('p','f'):=false add 19;
action('p','n'):=false add 20;
action('n','e'):=false add 21;
action('b','r'):=false add 22;
action('s','s'):=false add 23;
action('d','s'):=false add 24;
action('t','a'):=false add 25;
action('t','d'):=false add 26;
action('s','c'):=false add 27;
action('t','c'):=false add 28;
action('j','u'):=false add 29;
action('n','j'):=false add 30;
action('r','j'):=false add 31;
action('f','g'):=false add 32;
action('e','x'):=false add 33;
action('b','c'):=false add 34;
action('t','b'):=false add 35;
action('a','p'):=false add 36;
action('h','c'):=false add 37;
action('l','l'):=false add 38;
action('p','l'):=false add 39;
action('f','d'):=false add 40;
action('f','b'):=false add 41;
action('f','e'):=false add 42;
action('m','s'):=false add 43;
action('l','s'):=false add 44;
action('t','f'):=false add 45;
action('t','s'):=false add 46;
action('t','l'):=false add 47;
action('a','a'):=false add 48;
end initall;
\f
zone zout, contents(128*2,2,stderror);
integer array val,kind(1:250), table(0:127), instack(0:10), aix(1:5),
_ wordstart(1:52), bossline(1:100);
boolean array page(1:100,-2:100), action(32:126,32:126), tab, tabreg(1:2,1:100),
_ head,foot(1:1,0:100), frame_pos(1:100);
integer i,j,ci,li,pi,no,ll,pl,lb,pb,inix,chartype,inlno,spch,tabch,
_______ sptype,bm,tm,indents,comch,tempindent,tabtype,spacing,noofwords,
_ special,po,charmode,stdindent,stdll,pnof,contli,clevel,contpi,
_ exno,first_page,last_page,figno,blkch,bosslineno,
hyphenation_char,first_frame_pos,last_frame_pos,revision;
real cpu,base,time,cpu2,cpu3;
boolean fill,inputend,lineend,header,footer,lineno,test,english,clock,
_ rightjust,carriage,form_f,bosslinemode,
appendix,frame,qume,mess,normal_line,join;
\f
<*****************************************************
*
*
* main program
*
*
*****************************************************>
revision:=0;
cpu:=systime(1,0,base);
cpu3:=cpu2:=0;
initall;
if mess then
write(out,<:<10>ROFF version 1.:>,revision);
repeat <* until input end *>
repeat <* until normal_line *>
normal_line:=true;
if clock then
begin
cpu2:=systime(1,base,time)-cpu;
if (cpu2-cpu3)>1 then
begin
write(out,<< dddd.dd>,cpu2);
setposition(out,0,0);
cpu3:=cpu2;
end;
end;
readall(in,val,kind,1);
bosslineno:=bosslineno+10;
inlno:=inlno+1;
inix:=1;
if val(1)='sp' then
begin
while instack(0)<>0 do popindent;
changeline(false,0);
normalline:=false;
moveuntouched(1);
changeline(false,0);
end else
if val(1)='nl' then
begin
changeline(false,0);
normalline:=false;
while instack(0)<>0 do popindent;
changeline(false,1);
end else
if val(1)='-' or val(1)='*' or val(1)=blkch then
begin
if li>(pl-(tm+bm)-5) then
begin
changeline(false,0);
popindent;
outputpage(1);
pushindent(5);
settempindent(-2);
changeline(false,0);
end
else
begin
pushindent(5);
settempindent(-2);
changeline(false,0);
end;
val(2):=spch; kind(2):=chartype;
end else
\f
if val(1)=comch then
begin integer cmix;
cmix:=action(val(2),val(3)) extract 8;
if cmix=0 then
begin
errmess(<:illegal command:>,pi,li);
moveuntouched(1);
changeline(false,0);
normalline:=false;
end else
begin
integer p1,ix;
ix:=4;
case cmix of
begin
begin <* 1, sp *>
p1:=readoneparam(ix);
p1:=abs p1;
if p1>0 then changeline(false,0);
changeline(false,p1);
end sp;
begin <* 2, cc *>
if kind(4)<>sptype or kind(5)<>chartype then
errmess(<:command error, cc:>,pi,li) else
comch:=val(5);
end cc;
begin <* 3, ce *>;
changeline(false,0);
special:=4;
end ce;
begin <* 4, tm *>;
p1:=readoneparam(ix);
tm:=abs p1; <* note absolute udate *>
end tm;
begin <* 5, bm *>
p1:=readoneparam(ix);
bm:=abs p1; <* note absolute update *>
end bm;
begin <* 6, ul *>
charmode:=1;
special:=1;
end ul;
begin <* 7, in *>
p1:=readoneparam(ix);
indents:=indents+p1; <* note relative update *>
if indents<0 then indents:=0;
changeline(false,0);
end in;
begin <* 8, ti *>
p1:=readoneparam(ix);
settempindent(p1);
changeline(false,0);
end ti;
begin <* 9, fi *>
changeline(false,0);
fill:=true;
end fi;
begin <* 10, nf *>
changeline(false,0);
fill:=false;
end nf;
begin <* 11, np *>
p1:=readoneparam(ix);
p1:=abs p1;
if p1=0 then p1:=1;
changeline(false,0);
outputpage(p1);
end np;
begin <* 12, po *>
p1:=readoneparam(ix);
po:=abs p1; <* note absolute update *>;
end po;
begin <* 13, a1 *>
integer i,ci,eno,etx;
changeline(false,0);
outputpage(1);
page(li,-2):=false add 0;
ci:=1;
aix(1):=aix(1)+1;
for i:=2,3,4,5 do aix(i):=0;
if appendix then
begin
page(li,ci):=false add (aix(1) + 64);
ci:=ci+1;
end
else
writeno(aix(1),page,ci,li,0);
eno:=ci;
page(li,ci):=".";
for ci:=ci+1 step 1 until stdindent do page(li,ci):="sp";
page(li,-1):=false add (ci-1);
moveuntouched(5);
ci:=page(li,-1) extract 8;
special:=1;
for i:=1 step 1 until ci do page(li,i):=page(li,i) add (1 shift 8);
etx:=ci;
for ci:=ci+1 step 1 until stdll do page(li,ci):="sp";
ci:=ci-1;
i:=1;
while (page(li,i) extract 8) <> 'sp' do
begin
ci:=ci+1;
page(li,ci):=false add (page(li,i) extract 8);
i:=i+1;
end;
page(li,-1):=false add ci;
writecontents(li,eno,etx,pi,1);
changeline(false,2);
end a1;
begin <* 14, a2 *>
integer ci,i,eno,etx;
if li>(pl-(tm+bm)-15) then
begin
changeline(false,0);
outputpage(1);
end else
changeline(false,2);
page(li,-2):=false add 0;
ci:=1;
aix(2):=aix(2)+1;
for i:=3,4,5 do aix(i):=0;
if appendix then
begin
page(li,ci):=false add (aix(1) + 64);
ci:=ci+1;
end
else
writeno(aix(1),page,ci,li,0);
page(li,ci):=".";
ci:=ci+1;
writeno(aix(2),page,ci,li,0);
eno:=ci-1;
for ci:=ci step 1 until stdindent do page(li,ci):="sp";
page(li,-1):=false add (ci-1);
moveuntouched(5);
ci:=page(li,-1) extract 8;
special:=1;
for i:=1 step 1 until ci do page(li,i):=page(li,i) add (1 shift 8);
etx:=ci;
for ci:=ci+1 step 1 until stdll do page(li,ci):="sp";
ci:=ci-1;
i:=1;
while (page(li,i) extract 8)<>'sp' do
begin
ci:=ci+1;
page(li,ci):=false add (page(li,i) extract 8);
i:=i+1;
end;
page(li,-1):=false add ci;
if clevel>1 then writecontents(li,eno,etx,pi,2);
changeline(false,2);
end a2;
begin <* 15, a3 *>
integer ci,i,eno,etx;
if li>(pl-(tm+bm)-10) then
begin
changeline(false,0);
outputpage(1);
end else
changeline(false,2);
page(li,-2):=false add 0;
ci:=1;
aix(3):=aix(3)+1;
for i:=4,5 do aix(i):=0;
if appendix then
begin
page(li,ci):=false add (aix(1) + 64);
ci:=ci+1;
end
else
writeno(aix(1),page,ci,li,0);
page(li,ci):=".";
ci:=ci+1;
writeno(aix(2),page,ci,li,0);
page(li,ci):=".";
ci:=ci+1;
writeno(aix(3),page,ci,li,0);
eno:=ci-1;
for ci:=ci step 1 until stdindent do page(li,ci):="sp";
page(li,-1):=false add (ci-1);
moveuntouched(5);
ci:=page(li,-1) extract 8;
special:=1;
for i:=1 step 1 until ci do page(li,i):=page(li,i) add (1 shift 8);
etx:=ci;
for ci:=ci+1 step 1 until stdll do page(li,ci):="sp";
ci:=ci-1;
i:=1;
while (page(li,i) extract 8)<>'sp' do
begin
ci:=ci+1;
page(li,ci):=false add (page(li,i) extract 8);
i:=i+1;
end;
page(li,-1):=false add ci;
if clevel>2 then writecontents(li,eno,etx,pi,3);
changeline(false,2);
end a3;
begin <* 16, a4 *>
integer ci,i,eno,etx;
if li>(pl-(tm+bm)-10) then
begin
changeline(false,0);
outputpage(1);
end else
changeline(false,2);
page(li,-2):=false add 0;
ci:=1;
aix(4):=aix(4)+1;
for i:=5 do aix(i):=0;
if appendix then
begin
page(li,ci):=false add (aix(1) + 64);
ci:=ci+1;
end
else
writeno(aix(1),page,ci,li,0);
page(li,ci):=".";
ci:=ci+1;
writeno(aix(2),page,ci,li,0);
page(li,ci):=".";
ci:=ci+1;
writeno(aix(3),page,ci,li,0);
page(li,ci):=".";
ci:=ci+1;
writeno(aix(4),page,ci,li,0);
eno:=ci-1;
for ci:=ci step 1 until stdindent do page(li,ci):="sp";
page(li,-1):=false add (ci-1);
moveuntouched(5);
ci:=page(li,-1) extract 8;
special:=1;
for i:=1 step 1 until ci do page(li,i):=page(li,i) add (1 shift 8);
etx:=ci;
for ci:=ci+1 step 1 until stdll do page(li,ci):="sp";
ci:=ci-1;
i:=1;
while (page(li,i) extract 8)<>'sp' do
begin
ci:=ci+1;
page(li,ci):=false add (page(li,i) extract 8);
i:=i+1;
end;
page(li,-1):=false add ci;
if clevel>3 then write_contents(li,eno,etx,pi,4);
changeline(false,2);
end a4;
begin <* 17, he *>
integer array sp(1:2);
boolean array head2(1:1,0:100);
boolean ch;
integer i,ix,heix,heix2,delimno,spix,spno;
header:=true;
changeline(false,0);
delimno:=0;
ix:=4; while kind(ix)=sptype do ix:=ix+1;
heix2:=1;
while kind(ix)<>8 do
begin
if val(ix)='#' then
begin
head2(1,heix2):="#";
for i:=1 step 1 until pnof-1 do head(1,heix2+i):="sp";
heix2:=heix2+pnof;
end
else
begin
head2(1,heix2):=false add val(ix);
if val(ix)='ü' then delimno:=delimno+1;
heix2:=heix2+1;
end;
ix:=ix+1;
end while;
if delimno>2 then
begin
errmess(<:too many delimiters, he:>,pi,li);
moveuntouched(1);
changeline(false,0);
end
else
begin
heix2:=heix2-1;
spno:=stdll-heix2;
if delimno<2 then sp(1):=spno
else
begin
sp(1):=spno//2;
sp(2):=spno-sp(1);
end;
heix:=stdll;
spix:=1;
while heix>0 do
begin
if (head2(1,heix2) extract 8)='ü' then
begin
for i:=1 step 1 until sp(spix) do
begin
head(1,heix):="sp";
heix:=heix-1;
end;
spix:=spix+1;
heix:=heix-1;
heix2:=heix2-1;
end <* if ü *>
else
begin
ch:=head2(1,heix2);
if (ch extract 12 = spch) then ch:="sp";
head(1,heix):=ch;
if (head(1,heix) extract 8)='#' then
begin
head(1,0):=false add heix;
end;
heix:=heix-1; heix2:=heix2-1;
end elser;
end while;
end elser no error;
end he;
begin <* 18, fo *>
integer array sp(1:2);
boolean array foot2(1:1,0:100);
integer i,ix,foix,foix2,delimno,spix,spno;
boolean ch;
footer:=true;
changeline(false,0);
delimno:=0;
ix:=4; while kind(ix)=sptype do ix:=ix+1;
foix2:=1;
while kind(ix)<>8 do
begin
if val(ix)='#' then
begin
foot2(1,foix2):="#";
for i:=1 step 1 until pnof-1 do foot(1,foix2+i):="sp";
foix2:=foix2+pnof;
end
else
begin
foot2(1,foix2):=false add val(ix);
if val(ix)='ü' then delimno:=delimno+1;
foix2:=foix2+1;
end;
ix:=ix+1;
end while;
if delimno>2 then
begin
errmess(<:too many delimiters, fo:>,pi,li);
moveuntouched(1);
changeline(false,0);
end
else
begin
foix2:=foix2-1;
spno:=stdll-foix2;
if delimno<2 then sp(1):=spno
else
begin
sp(1):=spno//2;
sp(2):=spno-sp(1);
end;
foix:=stdll;
spix:=1;
while foix>0 do
begin
if (foot2(1,foix2) extract 8)='ü' then
begin
for i:=1 step 1 until sp(spix) do
begin
foot(1,foix):="sp";
foix:=foix-1;
end;
spix:=spix+1;
foix:=foix-1;
foix2:=foix2-1;
end <* if ü *>
else
begin
ch:=foot2(1,foix2);
if (ch extract 12 = spch) then ch:="sp";
foot(1,foix):=ch;
if (foot(1,foix) extract 8)='#' then
begin
foot(1,0):=false add foix;
end;
foix:=foix-1; foix2:=foix2-1;
end elser;
end while;
end elser no error;
end fo;
begin <* 19, pf *>
p1:=readoneparam(ix);
pnof:= abs p1; <* note absolute update *>
end pf;
begin <* 20, pn *>
p1:=readoneparam(ix);
pi:= abs p1; <* note absolute update *>
end pn;
begin <* 21, ne *>
p1:=readoneparam(ix);
if li>(pl-(tm+bm)-p1) then
begin
changeline(false,0);
outputpage(1);
end;
end ne;
begin <* 22, br *>
changeline(false,0);
end br;
begin <* 23, ss *>
spacing:=1;
end ss;
begin <* 24, ds *>
spacing:=2;
end ds;
begin <* 25, ta *>
integer no_of_params;
boolean error;
no_of_params:=0;
error:=false;
for i:=1,2 do
for j:=1 step 1 until 100 do
tab(i,j):=false;
repeat
p1:=readoneparam(ix);
no_of_params:=no_of_params+1;
if p1<0 then
begin
if (-p1)>ll then
begin
moveuntouched(1);
changeline(false,0);
errmess(<:tab delete beyond line limit, ta:>,pi,li);
error:=true;
end else
tab(1,(-p1)):=false;
end else
if p1>0 then
begin
if p1>ll then
begin
moveuntouched(1);
changeline(false,0);
errmess(<:tab set beyond line limit, ta:>,pi,li);
error:=true;
end
else
begin
tab(1,p1):=true;
if val(ix)='L' then tab(2,p1):=false add 1 else
if val(ix)='R' then tab(2,p1):=false add 2 else
if val(ix)='C' then tab(2,p1):=false add 3 else
_ tab(2,p1):=false add 1;
ix:=ix+1;
end;
end;
until p1=0 or kind(ix)=8 or error;
if (no_of_params=1) and (p1=0) and -,error then
begin <* clear all tabs *>
for i:=1,2 do
for j:=1 step 1 until 100 do
tab(i,j):=false;
end;
end ta;
begin <* 26, td *>
integer i;
if (pi>=first_page) and (pi<=last_page) then
begin
write(zout,"nl",1,"sp",po+(if lineno then 4 else 0));
for i:=1 step 1 until ll do outchar(zout,(if tab(1,i) then '!' else 'sp'));
write(zout,"nl",1,"sp",po+(if lineno then 4 else 0));
for i:=1 step 1 until ll do
outchar(zout,if tab(1,i) then (case (tab(2,i) extract 8) of ('L', 'R', 'C')) else 'sp');
outchar(zout,'nl');
end;
end td;
begin <* 27, sc *>
if kind(4)<>sptype or kind(5)<>chartype then
begin
errmess(<:command error, sc:>,pi,li);
moveuntouched(1);
changeline(false,0);
end else
spch:=val(5);
end sc;
begin <* 28, tc *>
if kind(4)<>sptype or kind(5)<>chartype then
begin
errmess(<:command error, tc:>,pi,li);
moveuntouched(1);
changeline(false,0);
end else
begin
table(tabch):=(chartype shift 12)+tabch;
table(val(5)):=(tabtype shift 12)+val(5);
tabch:=val(5);
intable(table);
end;
end tc;
begin <* 29, ju *>
changeline(false,0);
rightjust:=true;
end ju;
begin <* 30, nj *>
changeline(false,0);
rightjust:=false;
end nj;
begin <* 31, rj *>
ci:=page(li,-1) extract 8;
for i:=ci+1 step 1 until stdll do page(li,i):="sp";
page(li,-1):=false add stdll;
ci:=ll;
ll:=100;
moveuntouched(4);
ll:=ci;
changeline(false,0);
end rj;
begin <* 32, fg *>
changeline(false,0);
ci:=page(li,-1) extract 8;
for i:=1 step 1 until 4 do
begin
ci:=ci+1;
page(li,ci):=case i of ("F","i","g",".");
end;
ci:=ci+1;
figno:=figno+1;
writeno(figno,page,ci,li,3);
page(li,ci):=".";
ci:=ci+1;
page(li,ci):="sp";
page(li,-1):=false add ci;
moveuntouched(4);
special:=4;
changeline(false,0);
end fg;
begin <* 33, ex *>
changeline(false,0);
if li>(pl-(tm+bm)-5) then
outputpage(1);
ci:=page(li,-1) extract 8;
if english then
begin
for i:=1 step 1 until 7 do
begin
ci:=ci+1;
page(li,ci):=case i of ("E","x","a","m","p","l","e");
end;
end else
for i:=1 step 1 until 8 do
begin
ci:=ci+1;
page(li,ci):=case i of ("E","k","s","e","m","p","e","l");
end;
ci:=ci+1;
exno:=exno+1;
writeno(exno,page,ci,li,3);
page(li,ci):=".";
ci:=ci+1;
page(li,ci):="sp";
page(li,-1):=false add ci;
moveuntouched(4);
special:=1;
ci:=page(li,-1) extract 8;
for i:=1 step 1 until ci do page(li,i):=page(li,i) add (1 shift 8);
changeline(false,0);
end ex;
begin <* 34, bc *>
if kind(4)<>sptype or kind(5)<>chartype then
begin
errmess(<:command error, bc:>,li,pi);
moveuntouched(1);
changeline(false,0);
end else
blkch:=val(5);
end bc;
begin <* 35, tb - start text block *>
changeline(false,00);
if li>(pl-(tm+bm)-5) then outputpage(1);
p1:=readoneparam(ix);
moveuntouched(ix+1);
ci:=page(li,-1) extract 8;
for i:=ci+1 step 1 until indents+p1 do page(li,i):="@";
page(li,-1):=false add (indents+p1);
pushindent(p1);
join:=true;
end bl;
begin <* 36, ap - appendix start *>
appendix:=true;
for i:=1 step 1 until 5 do aix(i):=0;
end ap;
begin <* 37, hc - hyphenation character *>
if kind(4)<>sptype or kind(5)<>chartype then
begin
errmess(<:command error, hc:>,pi,li);
moveuntouched(1);
changeline(false,0);
end
else
hyphenation_char:=val(5);
end hc;
begin <* 38, ll - set line length *>
p1:=readoneparam(ix);
ll:=ll+ p1; <* note: relative update *>
end ll;
begin <* 39, pl - set page length *>
p1:=readoneparam(ix);
pl:=abs p1; <* note: absolute update *>
end pl;
begin <* 40, fd - frame definition *>
boolean error, first;
error:=false;
first:=true;
for i:=1 step 1 until 100 do frame_pos(i):=false;
first_frame_pos:=last_frame_pos:=1;
repeat
p1:=readoneparam(ix);
if (p1>stdll+7) or (p1<=0) then
begin error:=true;
errmess(<:frame def beyond page limit, ld:>,pi,li);
moveuntouched(1);
changeline(false,0);
end
else
begin <* position ok *>
if first then
begin <* first position *>
first_frame_pos:=p1;
first:=false;
end;
frame_pos(p1):=true;
last_frame_pos:=p1;
end position ok;
until (kind(ix)=8) or error;
end ld;
begin <* 41, fb - frame begin *>
changeline(false,0);
for i:=first_frame_pos step 1 until last_frame_pos do
page(li,i):="-";
page(li,-2):= false add (first_frame_pos - 1);
page(li,-1):= false add last_frame_pos;
frame:=false;
changeline(false,1);
frame:=true;
for i:=first_frame_pos step 1 until last_frame_pos do
page(li,i):="sp";
end lb;
begin <* 42, fe - frame end *>
frame:=false;
changeline(false,0);
for i:=first_frame_pos step 1 until last_frame_pos do
page(li,i):="-";
page(li,-2):=false add (first_frame_pos-1);
page(li,-1):=false add last_frame_pos;
changeline(false,1);
end le;
begin <* 43, ms - message *>
if mess then
begin <* write the message on current output *>
write(out,<:<10>message from :>,<< dd>,pi,li,":",1,"sp",1);
while kind(ix)<>8 do
begin
outchar(out,val(ix));
ix:=ix+1;
end;
setposition(out,0,0);
end mess;
end ms;
begin <* 44, ls - line spacing *>
p1:=readoneparam(ix);
spacing:=if p1=0 then 1 else abs p1;
end ls;
begin <* 45, tf - tab frame *>
integer tabkind,lastpos,cpos;
tabkind:=1; <* left *>
if kind(4)=sptype and kind(5)=chartype then
begin
if val(5)='R' then tabkind:=2
else if val(5)='C' then tabkind:=3;
end;
<* now clear all tabs *>
for i:=1,2 do
for j:=1 step 1 until 100 do tab(i,j):=false;
case tabkind of
begin
begin <* left *>
for i:=first_frame_pos step 1 until last_frame_pos-3 do
if frame_pos(i) then
begin
tab(1,i+2):=true;
tab(2,i+2):=false add 1;
end;
end left;
begin <* right *>
for i:=first_frame_pos+3 step 1 until last_frame_pos do
if frame_pos(i) then
begin
tab(1,i-2):=true;
tab(2,i-2):=false add 2;
end;
end right;
begin <* centre *>
last_pos:=first_frame_pos;
for i:=first_frame_pos+1 step 1 until last_frame_pos do
if frame_pos(i) then
begin
cpos:=last_pos + (i-last_pos)//2;
tab(1,cpos):=true;
tab(2,cpos):=false add 3;
lastpos:=i;
end;
end centre;
end case tabkind;
end tf;
begin <* 46, ts - tabs save *>
for i:=1,2 do
for j:=1 step 1 until 100 do tabreg(i,j):=tab(i,j);
end ts;
begin <* 47, tl - tabs load *>
for i:=1,2 do
for j:=1 step 1 until 100 do
tab(i,j):=tabreg(i,j);
end tl;
begin <* 48, aa - assign section numbers *>
i:=1;
repeat
p1:=readoneparam(ix);
p1:=if p1=0 then 1 else abs p1;
aix(i):=p1-1;
i:=i+1;
until (kind(ix)=8) or (p1=0) or (i=5);
for i:=i step 1 until 5 do aix(i):=0;
end aa;
end command case;
normalline:=false;
end command sequence;
end command ch;
until normalline;
lineend:=false;
\f
if fill then
begin <* fill *>
repeat <* process normal line *>
case kind(inix)-6 of
begin
begin <* 7, sp *>
while kind(inix)=sptype do inix:=inix+1;
end;
begin <* 8, em, end line *>
if val(inix)='em' then inputend:=true
else lineend:=true;
end;
begin <* 9, chars *>
if enterpage(inix)<>0 then <* inix is updated! *>
begin integer ix;
ix:=page(li,-2) extract 8;
if (page(li,-1) extract 8)=ix then
begin
while kind(inix)<>8 and ix<=ll do
begin
ix:=ix+1;
page(li,ix):=false add (val(inix) add (charmode shift 8));
inix:=inix+1;
end;
page(li,-1):=false add ix;
changeline(false,1);
errmess(<:1 word exceeds line length:>,pi,li);
end
else changeline(true,1);
end;
end case 9;
begin <* 10, tab char *>
tabulate(inix);
end case 10;
end case;
until lineend or inputend;
charmode:=0;
if special>3 then changeline(false,0);
end fill
else
begin <* no fill *>
moveuntouched(1);
changeline(false,0);
end no fill;
until inputend;
\f
changeline(false,0);
outputpage(1);
write(zout,form_f,1,"em",3);
write(contents,"nl",1,form_f,1,"em",3);
close(contents,true);
text_close(zout,true);
cpu:=systime(1,base,time)-cpu;
if mess then
write(out,<:<10>elapsed cpu time and real time:>,<<dddd.dd>,cpu,time);
setposition(out,0,0);
end
finis
▶EOF◀