|
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: 66048 (0x10200)
Types: TextFile
Notes: RCSL-52-AA-1036
Names: »rofftxt«
└─⟦a41ae585a⟧ Bits:30001842 SW-save af projekt 1000, Alarm-system
└─⟦72244f0ef⟧
└─⟦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 1053
*
* ROFF was programmed in feb. 1981 by ERK and STB
*
* Maintenance feb. 1981 - xx by STB
*
***************************************************************
\f
***************************************************************
*
* revision record:
*
* rev.no. installation init description
*
* 1.0 10.03.1981 STB first release
* 2.0 xx.05.1981 STB automatic index generation
* registers
* various corrections
* new commands:
* jo, bl, ix, xs, xc, rc, ar, fv
* ve, cl, bc
* new tutorial guide (replaces RCSL 52-AA1036
*
*
**************************************************************>
\f
<********* external procedures *****************
læs_fp_boo,
læs_fp_tal,
text_close,
text_open
*>
\f
integer procedure enterpage(ix);
integer ix; <* also result param *>
begin
integer i,ci,last_partition_possibility,last_partition_ix,last_index_mark;
last_partition_possibility:=0;
last_partition_ix:=0;
last_index_mark:=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;
end join;
end;
join:=false;
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
begin
last_partition_possibility:=ci+1;
last_partition_ix:=i;
end;
end
else
if val(i)=index_char then last_index_mark:=i-1
else
begin
if (val(i)='-') and (ci<ll) then
begin
last_partition_possibility:=ci+1;
last_partition_ix:=i;
end;
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:=last_partition_ix+1;
if val(ix)='-' then ix:=ix+1;
if indexon then
begin
if last_index_mark>0 then
divert_to_index_file( last_index_mark);
end;
noofwords:=noofwords+1;
page(li,-1):=false add last_partition_possibility;
bossline(li):=bosslineno;
end
else <* no possibility for partition *>
enterpage:=1;
end
else
begin
enterpage:=0;
ix:=i; <* next free input char *>
if indexon then
begin
if last_index_mark>0 then
divert_to_index_file( last_index_mark);
end;
page(li,-1):=false add ci; <* last used position in line *>
bossline(li):=bosslineno;
noofwords:=noofwords+1;
end;
end enterpage;
\f
procedure changeline(nobreak,no);
value nobreak,no; boolean nobreak; integer no;
begin integer i,x,y;
boolean no_change,empty_line;
no:=spacing*no;
join:=false;
no_change:=false;
if -,nobreak and bosslinemode then
begin
bossline(li):=bosslineno;
end bosslinemode;
if no<=0 then
begin
if (page(li,-2) extract 8)=(page(li,-1) extract 8) then
begin
no_change:=true;
end else no:=1;
end;
if auto_page_shift then
begin <* the page has been flipped automatically, hence we
will not start the new page with empty lines *>
if (page(li,-2) extract 8)=(page(li,-1) extract 8) then
empty_line:=true
else
begin <* check if the line is all spaces *>
x:=(page(li,-2) extract 8) + 1;
y:= page(li,-1) extract 8;
empty_line:=true;
while (x<=y) and empty_line do
begin
if (page(li,x) extract 8) <> 'sp' then empty_line:=false;
x:=x+1;
end;
end check for spaces;
if empty_line then no_change:=true
else auto_page_shift:=false;
end autopageshift;
if no_change then
begin <* don't change the line *>
page(li,-2):=page(li,-1):=false add indents;
cleartemps;
no_of_words:=0;
if special>3 or charmode=0 then special:=0;
end nochange
else
begin <* now change the line *>
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;
page(li,-3):=correction_line;
outputpage(1);
autopageshift:=true;
end;
if frame then
for i:=1 step 1 until last_frame_pos do
page(li,i):="sp";
page(li,-2):=page(li,-1):=false add indents;
page(li,-3):=correction_line;
cleartemps;
if special>3 or charmode=0 then special:=0;
end change;
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 po>=2 and page(i,-3) then <* make a correction line *>
write(zout,"sp",po-2,"!",1,"sp",x+1)
else
if (x<y) or bosslinemode then
write(zout,"sp",po+x);
if special<>0 then
begin
case special of
begin
begin <* underline word(s) *>
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);
write(zout,"sp",po+x);
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;
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
_ or page(i,-3) <* correction line *>) 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);
if page(i,-3) then write(zout,"sp",po-2,<:! :>)
else write(zout,"sp",po);
if bosslinemode then
write(zout,"sp",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;
page(li,-3):=correction_line;
first_index_on_page:=true;
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');
if lineno then write(zout,"sp",4);
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);
if lineno then write(zout,"sp",4);
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,start_app);
value lindex,no,etx,pindex,level,start_app;
integer lindex,no,etx,pindex,level;
boolean start_app;
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)
_ or (contli+lix+5>pl and start_app) 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+lix;
write(contents,"nl",lix);
end;
if start_app then
begin <* start appendix section *>
if english then
write(contents,"sp",po,<:Appendices::>,carriage,1,
_ "sp",po,false add 95,11,"nl",2)
else
write(contents,"sp",po,<:Bilag::>,carriage,1,
_ "sp",po,false add 95,6);
end appendix
else
begin <* normal contents line *>
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');
if (aix(1)//10) + (aix(2)//10) + (aix(3)//10) + (aix(4)//10) = 0 then
outchar(contents,'sp')
else inden:=inden-1;
for i:=stdindent+1 step 1 until etx do outchar(contents,page(lindex,i) extract 8);
write(contents,"sp",1,".",stdll-((etx-stdindent+1)+no+inden)-1);
for i:=1 step 1 until pnof do outchar(contents,pageno(1,i) extract 8);
end normal contents line;
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,start,char;
ci:=page(li,-1) extract 8;
start:=ci+1;
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
if val(ix)=indexchar then
begin
ci:=ci-1;
if indexon then
divert_to_index_file(ix-1);
end index char
else
if val(ix)=hyphenation_char then ci:=ci-1 else
page(li,ci):=false add (val(ix) add
_ (if val(ix)='sp' then 0 else (charmode shift 8)));
ix:=ix+1;
end;
end;
if val(ix)='em' then inputend:=true;
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)=sptype do ix:=ix+1;
if (val(ix)='+' or val(ix)='-' ) and (kind(ix)<>8) then
begin
sign:=if val(ix)='+' then 1 else -1;
ix:=ix+1;
end;
while val(ix)<='9' and val(ix)>='0' and kind(ix)<>8 do
begin
p1:=p1*10+(val(ix)-'0');
ix:=ix+1;
end;
p1:=p1*sign;
readoneparam:=p1;
testout(<:read one param:>,p1);
end rop;
\f
integer procedure read_param_char(ix);
integer ix; <* is updated *>
begin <* reads a parameter character *>
integer char;
while kind(ix)=sptype do ix:=ix+1;
char:=0;
if kind(ix)<>8 then
begin
read_param_char:=val(ix);
char:=val(ix);
ix:=ix+1;
end
else
read_param_char:=0;
testout(<:read param char:>,char);
end read param char;
\f
procedure cleartemps;
begin
indents:=indents-tempindent;
tempindent:=0;
end ct;
\f
procedure divert_to_index_file(last_pos);
value lastpos;
integer lastpos;
begin <* writes the word up to lastpos in
the val-array to the indexfile.
the first char is converted to a small letter if
'small_first_letter_in_index' is on and it is the only
big letter in the word *>
integer char, firstchar, i,firstpos;
boolean convert_first_char,continue;
if first_index_on_page then
begin
first_index_on_page:=false;
write(index,<<d>,pi,"nl",1);
end;
i:=lastpos;
continue:=true;
while i>0 and continue do
if val(i)=tabch or val(i)='sp' then
continue:=false else i:=i-1;
first_pos:=i+1;
first_char:=val(first_pos);
while ( (firstchar<'A')
_ or (firstchar>'Å' and firstchar<'a')
_ or (firstchar>'å') )
and (firstpos<lastpos) do
begin
firstpos:=firstpos+1;
firstchar:=val(firstpos);
end;
if small_first_letter_in_index then
begin
if first_char>=65 and first_char<=93 then
begin <* now find out if there are any other big
letters in the word *>
convert_first_char:=true;
for i:=firstpos+1 step 1 until lastpos do
begin
char:=val(i);
if char>=65 and char<=93 then convert_first_char:=false;
end;
end first was big
else convert_first_char:=false;
end
else
convert_first_char:=false;
if convert_first_char then val(first_pos):=first_char+32;
for i:=firstpos step 1 until lastpos do
begin
char:=val(i);
if char<>hyphenation_char and char<>tabch and char<>indexchar then
outchar(index,if char=spch then 'sp' else char);
end;
outchar(index,'nl');
end divert to index file;
\f
procedure indexsrtprc(zin,zout,zhelp,zsort,maxpoint,mess);
value maxpoint,mess; integer maxpoint; boolean mess;
zone zin,zout,zhelp,zsort;
begin <***************************************************
*
* i n d e x s o r t
*
* this procedure is used to assist an author in producing
* an index to his manual.
*
* its function is described in rcsl-no. 52-aa1014
*
* files:
* zin: holds the input text. the file must be open on call
* zout: will contain the index after call. must be open on call
* zhelp,
* zsort: auxilliary zones. must be closed on call.
* the procedure opens them to helplist and outlist resp.
* these files must exist.
*
* programmed october 1979 by oer
* modified november 1980 by stb (capital letters)
* - april 1981 by stb (procedure)
*
*********************************************************>
\f
<**********************************************************
strategi:
the input comes on file 'zin'.
indexsrtprc performs the following steps:
1. scan zin and for each element make a record on file 'zhelp'
2. call mdsortproc. the sorted records are delivered
_ on file 'zsort'.
3. scan 'zsort' and for each record write a line/pageno. in the
_ file 'zout', which eventually holds the index.
************************************************************>
\f
<********************************************>
<* declarations *>
<********************************************>
real array rec(1:18), names(1:6);
real array infile(1:2),outfile(1:2);
real array act_text(1:6);
integer array table(0:255), param(1:7), key_descr(1:6,1:2);
integer i,j,k,no_of_recs,max_length,result,explanation,act_point;
integer line_no,out_pos,out_line,lines_pr_page,in_char,act_char,p1,p2,p3;
boolean test;
boolean field capitals;
integer field len,point,typ;
real eof;
integer array field iaf;
real array field in_text,syn_text, sort_text;
\f
procedure set_table;
begin <*defines an in_table with all
characters having class 'text' except 'em' and 'nl'.
'nul' is blind *>
integer i,j,k;
for i:=1 step 1 until 255 do
table(i):=6 shift 12 + i;
table(0):=0;
table(10):=8 shift 12 + 10;
table(25):=8 shift 12 + 25;
table(36):=7 shift 12 + 36;
for j:=48 step 1 until 57 do
table(j):=2 shift 12 + j;
table(13):=13;
intable(table);
end set table;
\f
procedure create_sort_text;
begin <* copies rec.in_text to rec.sort_text while
converting capital letters to small letters.
if any capital letters occured then rec.capitals is set
to true *>
boolean caps;
integer point, in_char, sort_char,j;
real in_db_word, sort_db_word;
caps:=false;
for point:=1 step 1 until 5 do
begin <* copy a double word *>
in_db_word:=rec.in_text(point);
sort_db_word:=real<::>;
if in_db_word <> real<::> then
for j:=-40 step 8 until 0 do
begin <* copy a letter *>
in_char:=in_db_word shift j extract 8;
if (in_char>64) and (in_char<94) then
begin
caps:=true;
sort_char:=in_char+32;
end
else
sort_char:=in_char;
sort_db_word:=sort_db_word shift 8 add sort_char;
end;
rec.sort_text(point):=sort_db_word;
end;
rec.capitals:=caps;
end create sort text;
\f
procedure err1;
indexerrmess(<:missing index word:>);
procedure err2;
indexerrmess(<:too long index word:>);
procedure err3;
indexerrmess(<:too big page number:>);
procedure indexerrmess(s);
string s;
write(out,<:<10>page: :>,<<dd>,actpoint,"sp",1,s);
\f
<********************************************>
<* initializations *>
<********************************************>
set_table;
sort_text:=4;
syn_text:=52;
in_text:=32;
for i:=1 step 1 until 6 do
act_text(i):=real <::>;
test:=true;
len:=2;
iaf:=0;
capitals:=29;
point:=28;
typ:=26;
p1:=0; p2:=0; p3:=0;
line_no:=10;
open(zhelp,4,<:helplist:>,0);
\f
<********************************************>
<* now read the lines and copy them to zhelp as records *>
<********************************************>
no_of_recs:=0;
max_length:=52;
act_point:=0;
act_char:=0;
repeat
for i:=1 step 1 until 18 do
rec(i):=real<::>;
i:=readchar(zin,j);
line_no:=line_no+10;
case i of
begin
;
begin <* pagenumber *>
repeatchar(zin);
read(zin,act_point);
if act_point > max_point then err3;
end;
;;;
begin <* character *>
if j=35 then
begin <* f or ff *>
readchar(zin,j);
if j=35 then
begin <* ff *>
k:=readstring(zin,rec,9);
if k=0 then err1;
if k>5 then err2;
rec.len:=32;
rec.typ:=3;
rec.point:=act_point;
end
else
begin <* f *>
repeatchar(zin);
k:=readstring(zin,rec,9);
if k=0 then err1;
if k>5 then err2;
rec.len:=32;
rec.typ:=2;
rec.point:=act_point;
end
end
else
begin <* keyword *>
repeatchar(zin);
k:=readstring(zin,rec,9);
if k=0 then err1;
if k>5 then err2;
rec.len:=32;
rec.typ:=1;
rec.point:=act_point;
end;
end;
begin <* synonym *>
k:=readstring(zin,rec,9);
if k=0 then err1;
if k>5 then err2;
k:=readstring(zin,rec,14);
if k=0 then err1;
if k>5 then err2;
rec.len:=72;
rec.typ:=4;
max_length:=72;
end;
;
end case;
if (j<48) or (j>57) then
begin
create_sort_text;
if rec.capitals and (rec.typ<>4) then rec.len:=52;
outvar(zhelp,rec);
no_of_recs:=no_of_recs+1;
end;
until i=8;
for i:=1 step 1 until 12 do
rec(i):=real<::>;
rec.len:=32;
outvar(zhelp,rec);
close(zhelp,false);
\f
<********************************************************>
<* now set up the parameters for the call of mdsortproc *>
<********************************************************>
param(1):=1; <* segments pr in_block *>
param(2):=1; <* clear input is ok *>
param(3):=1; <* segments pr out_block *>
param(4):=0; <* variable record length *>
param(5):=max_length;
param(6):=6; <* no of keys *>
param(7):=0; <* don't print expected time *>
key_descr(1,1):=3; <* type = long, ascending *>
key_descr(1,2):=8; <* position *>
key_descr(2,1):=3;
key_descr(2,2):=12;
key_descr(3,1):=3;
key_descr(3,2):=16;
key_descr(4,1):=3;
key_descr(4,2):=20;
key_descr(5,1):=3;
key_descr(5,2):=24;
key_descr(6,1):=2; <* integer, ascending *>
key_descr(6,2):=28;
names(1):=real<:helpl:> add 'i';
names(2):=real<:st:>;
names(3):=real<:outli:> add 's';
names(4):=real<:t:>;
names(5):=real<::>;
names(6):=real<::>;
mdsortproc(param,key_descr,names,eof,no_of_recs,result,explanation);
if mess then write(out,<:<10>result of index was:>,result,explanation,"nl",1);
\f
open(zsort,4,<:outlist:>,0);
<*********************************************>
<* make the outputfile *>
<*********************************************>
for i:=1 step 1 until 6 do act_text(i):=real<::>;
lines_pr_page:=pl-(tm+bm);
out_pos:=0;
out_line:=5;
act_char:=0;
outputtoppage;
write(zout,"nl",1,"sp",po);
outchar(zout,aix(1)+64);
write(zout,".",1,"sp",stdindent-2);
if english then
write(zout,<:INDEX:>,"sp",stdll-5-stdindent)
else write(zout,<:STIKORDSREGISTER:>,"sp",stdll-16-stdindent);
outchar(zout,aix(1)+64);
outchar(zout,'.');
write(zout,carriage,1,"sp",po,
_ false add 95,stdindent+(if english then 5 else 16),
_ "nl",2);
for i:=1 step 1 until no_of_recs do
begin
invar(zsort);
<* first find out if a new word is coming *>
j:=1;
while (act_text(j)=zsort.sort_text(j)) and (j<6) do j:=j+1;
<* now if j is less than 6 it is a new word *>
if j<6 then
begin <* new text *>
if out_line >lines_pr_page then
begin
li:=outline;
output_bottom_page;
out_pos:=0;
pi:=pi+1;
out_line:=1;
outputtoppage;
end;
in_char:=zsort.sort_text(1) shift (-40) extract (8);
if act_char <> in_char then
begin <* new first-letter *>
act_char:=in_char;
write(zout,"nl",1);
out_line:=out_line+1;
end;
write(zout,"nl",1);
k:=1;
write(zout, ".", 39- write(zout, <: :>,
_ if zsort.capitals then string zsort.in_text(increase(k))
_ else string zsort.sort_text(increase(k))
_ ), <: :>);
out_line:=out_line+1;
out_pos:=41;
for j:=1 step 1 until 5 do
act_text(j):=zsort.sort_text(j);
act_text(6):=real<::>; <* type and page-no. *>
end;
if (act_text(6)<>zsort.sort_text(6)) or (j<6) then
begin
act_text(6):=zsort.sort_text(6); <* type and point (i.e. pageno. *>
<* this is in order not to print the same pageno. twice, even
if the user has specified it twice on the same page (by mistake) *>
case zsort.typ of
begin
begin <* only pagenumber *>
if out_pos > 62 then
begin
out_pos:=write(zout,"nl",1," ",41,zsort.point);
out_line:=out_line+1;
end
else
if out_pos<> 41 then
out_pos:=out_pos+write(zout,<:,:>,zsort.point)
else
out_pos:=out_pos+write(zout,zsort.point);
end;
begin <* pageno and f *>
if out_pos > 62 then
begin
out_pos:=write(zout,"nl",1," ",41,zsort.point,<: f.:>);
out_line:=out_line+1;
end
else
if out_pos<>41 then
out_pos:=out_pos+write(zout,<:,:>,zsort.point,<: f.:>)
else
out_pos:=out_pos+write(zout,zsort.point,<: f.:>);
end;
begin <* pageno and ff *>
if out_pos > 62 then
begin
out_pos:=write(zout,"nl",1," ",41,zsort.point,<: ff.:>);
out_line:=out_line+1;
end
else
if out_pos <> 41 then
out_pos:=out_pos+write(zout,<:,:>,zsort.point,<: ff.:>)
else
out_pos:=out_pos+write(zout,zsort.point,<: ff.:>);
end;
begin <* syn text *>
k:=1;
out_pos:=out_pos+write(zout,<: :>,string zsort.syn_text(increase(k)));
end;
end case;
end;
end for;
li:=outline;
outputbottompage;
end index sort proc;
\f
procedure insert_register(reg_no,ix);
value reg_no;
integer reg_no,ix; <* ix is updated *>
begin <* inserts the value of the register into the
'val'-array. ix points to the reg_char.
after the call ix points just after the inserted number *>
integer reg_value, needed_room,i,absval;
reg_value:=
if reg_no='f' then fig_no
else if regno='F' then figno+1
else if regno='e' then exno
else if regno='E' then exno+1
else if regno='p' then pi
else if regno='P' then pi+1
else if regno='1' then aix(1)
else if regno='2' then aix(2)
else if regno='3' then aix(3)
else if regno='4' then aix(4)
else reg(regno);
absval:=abs(regvalue);
needed_room:=if regvalue=0 then 1 else
_ entier( ln(absval)/ln(10) )
_ + (if regvalue<0 then 2 else 1);
ix:=needed_room+ix; <* ix points now just after the number *>
<* now move the remaining part part of val 'neededroom' positions
to the right to give room for the no *>
if neededroom=1 then
begin
<* no: move one pos left !! *>
for i:=ix step 1 until chars_read-1 do
begin
val(i):=val(i+1);
kind(i):=kind(i+1);
end
end
else if neededroom>2 then
for i:=chars_read+neededroom-1 step -1 until ix+neededroom-1 do
begin
val(i):=val(i-neededroom);
kind(i):=kind(i-neededroom);
end;
<* if needed room = 2 then do nothing *>
i:=ix-1; <* last pos of the number *>
repeat
val(i):=(absval mod 10) + '0';
kind(i):=chartype;
absval:=absval//10;
i:=i-1;
until absval=0;
if regvalue<0 then
begin
val(i):='-';
kind(i):=chartype;
end;
charsread:=charsread+(if neededroom=1 then -1
_ else if neededroom=2 then 0
_ else neededroom);
end insert register;
procedure errmess(s,pi,li);
string s; integer pi,li;
begin
write(out,<:<10>page: :>,<<dd>,pi,<:, line: :>,li);
if bosslinemode then
write(out,<:, bossline: :>,<<ddddd>,bosslineno,":",1,"sp",1);
write(out,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 write_no_in_text(no);
value no; integer no;
begin <* the procedure writes 'no' in the text as
if it had been typed in a normal inputline.
used to insert e.g. references to fig no's and ex no's *>
integer needed_room,ci;
ci:=page(li,-1) extract 8;
needed_room:=(if no<10 then 1
_ else if no<100 then 2 else 3)
_ + 1 <* leading space *>;
if ll-ci<needed_room then
begin
changeline(true,1);
ci:=page(li,-1) extract 8;
end;
if ci<>(page(li,-2) extract 8) then
begin
ci:=ci+1;
page(li,ci):="sp";
if join then
begin
ci:=ci-1;
join:=false;
end join;
end;
ci:=ci+1;
no_of_words:=no_of_words+1;
wordstart(no_of_words):=ci;
write_no(no,page,ci,li,0);
page(li,-1):=false add (ci-1);
end write no in text;
\f
procedure section(level);
value level; integer level;
begin <* starts a new section. if level=1 then it's
a new chapter and we start a new page. The
new section is written in the 'contents' file *>
integer i,ci,eno,etx;
while instack(0)<>0 do popindent;
cleartemps;
indents:=stdindent;
if (level=1) or (li>pl-(tm+bm)-8) then
begin <* new page *>
changeline(false,0);
outputpage(1);
end
else changeline(false,2);
page(li,-2):=false add 0;
ci:=1;
aix(level):=aix(level)+1;
for i:=level+1 step 1 until 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);
if level=1 then
begin <* new chapter *>
eno:=ci;
page(li,ci):=".";
ci:=ci+1;
end new chapter
else
begin <* level > 1 *>
for i:=2 step 1 until level do
begin
page(li,ci):=".";
ci:=ci+1;
writeno(aix(i),page,ci,li,0);
end;
eno:=ci-1;
end;
if ci>=stdindent then
begin
page(li,ci):="sp";
ci:=ci+1;
end;
for ci:=ci step 1 until stdindent do page(li,ci):="sp";
page(li,-1):=false add (ci-1);
if kind(4)<>8 then 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;
<* now copy the section number *>
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 level<=clevel then
writecontents(li,eno,etx,pi,level,false);
changeline(false,2);
end section;
\f
procedure tabulate(inputix);
integer inputix;
begin
integer ix,tabix,wix,wordwidth,tabwidth,i,maxtab;
boolean error;
error:=false;
repeat <* until no more consequtive tabs *>
tabix:=ix:=(page(li,-1) extract 8)+1;
maxtab:=if fill then ll else stdll+7;
while -, tab(1,tabix) and tabix<=maxtab do tabix:=tabix+1;
if tabix>maxtab then
begin
errmess(<:tabulation exceeds page:>, 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,<:*test* :>,pi,"sp",1,li,"sp",1,bosslineno,"sp",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);
open(contents,4,<:contents:>,0);
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:>);
if first_page=0 then first_page:=læsfptal(<:f:>);
last_page:=læsfptal(<:last:>);
if last_page=0 then last_page:=læsfptal(<:l:>);
if last_page=0 then last_page:=1000000;
indexon:=false;
small_first_letter_in_index:=false;
læsfpboo(<:index:>,indexon);
if indexon then
begin <* open the index file *>
open(index,4,<:index:>,0);
first_index_on_page:=true;
small_first_letter_in_index:=true;
end;
indexchar:='^';
for i:=0 step 1 until 127 do reg(i):=0;
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:='>';
reg_char:=0;
rightjust:=true;
noofwords:=0;
fill:=true;
contpi:=0;
contli:=10000;
inputend:=lineend:=false;
appendix:=false;
frame:=false;
join:=false;
footer:=false;
header:=true;
correction_line:=false;
autopageshift:=false;
version:=0;
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;
page(li,-3):=correction_line;
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;
action('i','x'):=false add 50;
action('j','o'):=false add 51;
action('x','c'):=false add 52;
action('f','v'):=false add 53;
action('b','l'):=false add 54;
action('x','s'):=false add 55;
action('a','r'):=false add 56;
action('r','c'):=false add 57;
action('v','e'):=false add 58;
action('c','l'):=false add 59;
end initall;
\f
zone zout, contents, index(128*2,1,stderror);
integer array val,kind(1:250), table,reg(0:127), instack(0:10), aix(1:5),
_ wordstart(1:52), bossline(1:100);
boolean array page(1:100,-3: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,indexchar,
chars_read,reg_char,p1,ix,version;
real cpu,base,time,cpu2,cpu3;
boolean fill,inputend,lineend,header,footer,lineno,test,english,clock,
_ rightjust,carriage,form_f,bosslinemode,
small_first_letter_in_index,correction_line,autopageshift,
appendix,frame,qume,mess,normal_line,join,indexon,first_index_on_page;
\f
<*****************************************************
*
*
* main program
*
*
*****************************************************>
revision:=19;
cpu:=systime(1,0,base);
cpu3:=cpu2:=0;
initall;
if mess then
write(out,<:<10>ROFF version 1.:>,<<d>,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;
charsread:=readall(in,val,kind,1);
if regchar<>0 then
begin <* scan the line and evaluate possible register calls *>
ix:=1;
while kind(ix)<>8 do
begin
if val(ix)=regchar then insertregister(val(ix+1),ix)
else ix:=ix+1;
end while;
end regchar<>0;
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);
page(li,-3):=correctionline;
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)=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
ix:=4;
case cmix of
begin
begin <* 1, sp *>
p1:=abs readoneparam(ix);
if p1>0 then changeline(false,0);
changeline(false,p1);
end sp;
begin <* 2, cc *>
comch:=readparamchar(ix);
end cc;
begin <* 3, ce *>;
changeline(false,0);
special:=4;
end ce;
begin <* 4, tm *>;
tm:=abs readoneparam(ix);
end tm;
begin <* 5, bm *>
bm:=abs readoneparam(ix);
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:=abs readoneparam(ix);
if p1=0 then p1:=1;
changeline(false,1);
outputpage(p1);
autopageshift:=false;
end np;
begin <* 12, po *>
po:=abs readoneparam(ix);
end po;
begin <* 13, a1 - start chapter *>
section(1);
end;
begin <* 14, a2 - start section *>
section(2);
end;
begin <* 15, a3 - start subsection *>
section(3);
end;
begin <* 16, a4 - start sub-sub-section *>
section(4);
end;
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;
for i:=1 step 1 until 100 do head(1,i):=head2(1,i):="sp";
head(1,0):=false add 0;
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:=if delimno=0 then stdll-spno//2 else stdll;
spix:=1;
while heix>0 and heix2>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;
for i:=1 step 1 until 100 do foot(1,i):=foot2(1,i):="sp";
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:=if delimno=0 then stdll-spno//2 else stdll;
spix:=1;
while foix>0 and foix2>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 *>
pnof:=abs readoneparam(ix);
end pf;
begin <* 20, pn *>
pi:=0;
repeat
pi:=pi+readoneparam(ix);
until kind(ix)=8;
if indexon then write(index,<<d>,pi,"nl",1);
end pn;
begin <* 21, ne *>
p1:=readoneparam(ix);
if li>(pl-(tm+bm)-p1) then
begin
changeline(false,0);
outputpage(1);
autopageshift:=false;
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 maxtab;
boolean error;
maxtab:=if fill then ll else stdll+7;
error:=false;
for i:=1,2 do
for j:=1 step 1 until 100 do
tab(i,j):=false;
repeat
p1:=abs readoneparam(ix);
if p1>0 then
begin
if p1>maxtab then
begin
moveuntouched(1);
changeline(false,0);
errmess(<:tab set beyond page 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
begin
tab(2,p1):=false add 1;
ix:=ix-1;
end;
ix:=ix+1;
end;
end;
until p1=0 or kind(ix)=8 or error;
end ta;
begin <* 26, td *>
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 *>
spch:=readparamchar(ix);
end sc;
begin <* 28, tc *>
if tabch<>0 then
begin <* clear the old tab char *>
table(tabch):=(chartype shift 12) + tabch;
end;
tabch:=readparamchar(ix);
if tabch<>0 then table(tabch):=(tabtype shift 12) + tabch;
intable(table);
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 - block character *>
blkch:=readparamchar(ix);
end ;
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 tb;
begin <* 36, ap - appendix start *>
appendix:=true;
writecontents(0,0,0,0,1,true);
for i:=1 step 1 until 5 do aix(i):=0;
end ap;
begin <* 37, hc - hyphenation character *>
hyphenation_char:=readparamchar(ix);
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 *>
pl:=abs readoneparam(ix);
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, fd:>,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 fd;
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:=1 step 1 until last_frame_pos do
page(li,i):="sp";
end fb;
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 fe;
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;
p1:=readparamchar(ix);
tabkind:=
_ if p1='R' then 2
_ else if p1='C' then 3
_ else 1 <* left *>;
<* 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;
i:=i+1;
until (kind(ix)=8) or (p1=0) or (i=5);
aix(i-1):=aix(i-1)-1;
for i:=i step 1 until 5 do aix(i):=0;
end aa;
begin <* 49, unused *>
end ;
begin <* 50, ix - divert to index file *>
if indexon then
begin
<* first skip possible spaces *>
while kind(ix)<>8 and kind(ix)=sptype do ix:=ix+1;
if first_index_on_page then
begin <* write the page number on the index file *>
write(index,<<d>,pi,"nl",1);
first_index_on_page:=false;
end;
while kind(ix)<>8 do
begin
outchar(index,val(ix));
ix:=ix+1;
end;
outchar(index,'nl');
end indexon;
end ix;
begin <* 51, jo - join *>
join:=true;
end jo;
begin <* 52, xc - index char *>
indexchar:=readparamchar(ix);
end xc;
begin <* 53, fv - frame visual definition *>
integer pos;
boolean error;
error:=false;
for i:=1 step 1 until 100 do frame_pos(i):=false;
pos:=readoneparam(ix);
if pos<=0 or pos>100 then error:=true
else
begin
while kind(ix)<>8 and val(ix)<>'!' do ix:=ix+1;
first_frame_pos:=pos;
while kind(ix)<>8 and -, error do
begin
if val(ix)='!' then
begin
if pos>100 then error:=true else
begin
framepos(pos):=true;
lastframepos:=pos;
end;
end;
pos:=pos+1;
ix:=ix+1;
end while;
end 1<pos<100;
if error then
begin errmess(<:frame def outside page, fv:>,pi,li);
moveuntouched(1);
changeline(false,0);
end error;
end fv;
begin <* 54, bl - set bossline number *>
bosslineno:=readoneparam(ix);
end bl;
begin <* 55, xs - index convert first letter to small *>
p1:=readparamchar(ix);
if p1='+' then small_first_letter_in_index:=true
else if p1='-' then small_first_letter_in_index:=false
else
begin
errmess(<:command error, xs:>,pi,li);
moveuntouched(1);
changeline(false,0);
end;
end xs;
begin <* 56, ar - assign to register *>
integer reg_no,operator,operation;
regno:=readparamchar(ix);
reg(regno):=0;
repeat
operator:=readparamchar(ix);
operation:= if operator='*' then 1
_ else if operator='/' then 2
_ else 3;
if operation=3 then ix:=ix-1;
reg(regno):= case operation of (
_ reg(regno) * readoneparam(ix),
_ reg(regno) // readoneparam(ix),
_ reg(regno) + readoneparam(ix) );
until kind(ix)=8;
end ar;
begin <* 57, rc - set register char *>
regchar:=readparamchar(ix);
end rc;
begin <* 58, ve - version definition *>
version:=abs readoneparam(ix);
end;
begin <* 59, cl - correction line *>
p1:=readoneparam(ix);
if (abs p1)=version then
begin
correction_line:=p1>0;
page(li,-3):=correction_line or fill;
end;
end cl;
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, ff *>
if val(inix)='em' then inputend:=true
else
if val(inix)='ff' then
begin
line_end:=true;
inix:=inix+1;
bosslineno:=(bosslineno//1000 + 1)*1000
end
else line_end:=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);
charmode:=0;
end no fill;
until inputend;
\f
changeline(false,0);
outputpage(1);
if indexon then
begin
zone zhelp,zsort(128,1,stderror);
if -,appendix then
begin
appendix:=true;
writecontents(0,0,0,0,1,true);
for i:=1 step 1 until 5 do aix(i):=0;
end not appendix;
aix(1):=aix(1)+1;
write(contents,"nl",2,"sp",po,false add (aix(1)+64),1,
_ if english then <:. INDEX :> else <:. STIKORDSREGISTER :>,
_ ".",stdll-(if english then 9 else 20) ,
_ <<ddd>,pi);
write(index,"em",3);
setposition(index,0,0);
indexsrtprc(index,zout,zhelp,zsort,pi-1,mess);
end;
write(contents,"nl",1,form_f,1,"em",3);
close(contents,true);
write(zout,form_f,1,"em",3);
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◀