(*$U+*)
program syndia(output,input_f,list);

type
alfa=string[12];
iso=char;

var
nl,cr:char;
macro_no:integer;
pos_adjust,help: integer;

const
max=1000;
def_max=300;
name_def_max=6000;
title_max=100;
d_fill=2;
d_pagelength=70;
d_linelength=87;
d_head=4;
d_line_space=4;
d_left_margin=2;
d_pmargin=12;
d_indent=2;
d_center=0;
d_time='            ';
d_date='            ';
d_page_nr=0;
d_qume=false;
d_rctekst=true;
d_rcindex=true;
d_tpt=15;
d_rctpt=10;
d_lpt=6;
d_rclpt=6;
d_rcwidth=58;
d_frame=false;

type
nodeptr=^node;
  nodeptrs=array[boolean] of nodeptr;

node=record
length:integer;
split,more:integer;
indiff,outdiff:integer;
case art:char of
't','n','e':(namestart,namelength:integer);
'&','+','!','/':(childs:nodeptrs)
end;

var
is_error: boolean;
list, input_f:text;
temp:text;
token:char;
lastch:char;
tokenstart,tokenlength:integer;
namebuffer:array[0..max] of char;
name_def_free: integer;
def_free: integer;
def_next: integer;
def_overflow: boolean;
name_def:array[0..name_def_max] of char;
def:array[0..def_max] of record
             namestart,namelength,page: integer;
             macro: string[8];
           end;
             
lineno:integer;
morequme:boolean;
moreframe:boolean;
moretimes:integer;
frametermfirst,frametermlast,framenonterm:char;
connectline:char;
line_ch:char;
period_pos: integer;

(* system parameters *)
input_file,syntax_file:alfa;
param_no:integer;
param_error,param_finis:boolean;
fill:integer;
connection:boolean;
pagelength,linelength:integer;
head,left_margin,pmargin,make_margin,indent,center:integer;
line_space:integer;
title: string[title_max];
date_v:alfa;
time_v:alfa;
page_nr:integer;
write_page_nr:boolean;
qume:boolean;
rctekst, rcindex:boolean;
tpt,lpt,rctpt, rclpt, rcwidth:integer;
frame:boolean;
i: integer;
space_written: integer;

procedure write_ch(ch: char);
begin
  if ch=' ' then space_written:= space_written + 1 else
  begin
    if space_written > 0 then begin
      write(list,' ': space_written);
      space_written:= 0;
    end;
    write(list, ch);
  end;
end;
procedure start_line(margin: integer);
begin
  if tpt=15 then write(list,chr(163)); (* set / *)
  space_written:= margin;
end;

procedure writeformat(tpt,lpt: integer;format:char);
var i:integer;
begin
  write(list,chr(4),chr(0),'-',format,chr(tpt),chr(0),chr(lpt),chr(0),chr(0));
  write(list,chr(0),chr(0),chr(2),chr(1),chr(rcwidth),'1',chr(0));
  for i:=16 to 39 do write(list,chr(0));
  for i:=40 to 54 do write(list,chr(5 + (i-40)*10));
  write(list,chr(255));
  write(list,chr(4));
end;

procedure page(var f: text);
begin
  writeln(f,chr(12));
end;

function nextch:char;
var ch:char;
begin
if lastch=' ' then
begin
repeat
if eof(input_f) then
begin
ch:='.';
end
else begin
  if eoln(input_f) then 
  begin readln(input_f); ch:=' '; end
  else read(input_f,ch);
end;
until (' '<=ch) and (ch<='~');
if ('A'<=ch) and (ch<='Z') then ch:=chr(ord(ch)-ord('A')+ord('a'));
nextch:=ch;
end
else
begin
nextch:=lastch;
lastch:=' ';
end;
end;

procedure putinput(c:char);
begin
  if lastch=' ' then lastch:=c;
end;

procedure skip(c:char);
begin
while token=c do token:=nextch;
end;

procedure insertch(var i:integer; ch:char);
begin
if i<=max then
begin
namebuffer[i]:=ch;
i:=i+1;
end;
end;

procedure readstring;
var i:integer;
ch:char;
begin
tokenstart:=tokenstart+tokenlength;
  i:=tokenstart;
  repeat
ch:=nextch;
while (ch<>'''') and not eof(input_f) do
begin
insertch(i,ch);
ch:=nextch;
end;
ch:=nextch;
if ch='''' then insertch(i,ch);
until ch<>'''';
putinput(ch);
tokenlength:=i-tokenstart;
token:='a';
end;

procedure readalfa;
var
ch:char;
  i:integer;
begin
ch:=token;
tokenstart:=tokenstart+tokenlength;
i:=tokenstart;
while ch=' ' do ch:=nextch;
if ('a'<=ch) and (ch<='z') then
repeat
insertch(i,ch);
ch:=nextch;
until not((('a'<=ch)and(ch<='z'))or(('0'<=ch)and(ch<='9')));
putinput(ch);
token:='a';
tokenlength:=i-tokenstart;
end;


procedure gettoken;
begin
if not is_error then
begin
token:=nextch;
skip(' ');
if ('a'<=token) and (token<='z') then
begin
readalfa;
end else
case token of
'''':begin
readstring;
end;
'"':;
end;
end;
end;

procedure check_page(length:integer);
var i:integer;
   take:integer;
   title_length:integer;
begin
if not rctekst then 
begin
  lineno:=lineno+line_space+length;
  if lineno>=pagelength then
  begin
lineno:=head+line_space+length;
page(list);
take:=1;
if write_page_nr then take:=take+10;
if date_v<>' ' then take:=take+10;
if time_v<>' ' then take:=take+10;
for i:=1 to head-1 do writeln(list);
if take>1 then
begin
if left_margin>0 then write(list,' ':left_margin);
title_length:= linelength-left_margin-take;
if title_length>len(title)
then write(list,title:len(title),' ':title_length-len(title))
else write(list,title:title_length);
write(list,' ');
if date_v<>' ' then write(list,date_v:10);
if time_v<>' ' then write(list,time_v:10);
if write_page_nr then writeln(list,'page',page_nr:6)
else writeln(list);
end else writeln(list);
page_nr:=page_nr+1;
end;
for i:=1 to line_space do writeln(list);
end;
end;

procedure comment;
var lines:integer;
   i:integer;
 last:iso;
 ch: char;
begin
if rctekst
then begin
repeat lastch:=' '; gettoken; until token='"';
lastch:=' ';
gettoken;
end
else begin
  assign(temp,'syndia.tmp');
  rewrite(temp);
lines:=0;
last:=nl;
if not eof(input_f) then
if eoln(input_f) then readln(input_f);
read(input_f,ch);
  while (ch<>'"') and not eof(input_f) do
begin
if last=nl then
begin
for i:=1 to left_margin do
begin
write(temp,' ');
end;
lines:=lines+1;
end;
write(temp,ch);
last:=ch;
if eoln(input_f) then begin ch:=chr(10); readln(input_f) end else read(input_f,ch); 
end;
if last<>nl then
begin
writeln(temp)
end;
if ch='"' then;
gettoken;
check_page(lines);
close(temp);
reset(temp);
while not eof(temp) do
begin
  if eoln(temp) then begin readln(temp); writeln(list) end else
  begin read(temp,ch); write(list,ch); end;
end;
close(temp);
end;
end;

procedure rule;
var
left,rigth,lab:nodeptr;
currentline:integer;
i:integer;
defined:boolean;
new_ptr:^integer;
help:integer;
macro:string[8];
  
function maxi(a,b:integer):integer;
begin
if a<b
then maxi:=b
else maxi:=a;
end;

procedure error(readtoken,expected:char);
begin
writeln(' **** error input read = ',readtoken,'  expected = ',expected);
writeln('      syntax rule skipped');
while (token<>';') and (token<>'.') do gettoken;
is_error:=true;
end;

procedure check(c:char);
begin
   if token<>c then error(token,c);
  gettoken;
end;

procedure terminal(var expr:nodeptr);
begin
new(expr(*,'t'*));
with expr^ do
begin
art:='t';
length:=tokenlength+2*fill;
namestart:=tokenstart;
namelength:=tokenlength;
split:=1;
more:=0;
indiff:=0;
outdiff:=0;
end;
gettoken;
end;

procedure nonterminal(var expr:nodeptr);
begin
new(expr(*,'n'*));
with expr^ do
begin
art:='n';
  length:=tokenlength+2*fill;
  namestart:=tokenstart;
  namelength:=tokenlength;
split:=1;
more:=0;
indiff:=0;
outdiff:=0;
end;
gettoken;
end;

procedure empty(var expr:nodeptr);
begin
new(expr(*,'e'*));
with expr^ do
begin
art:='e';
length:=1;
namestart:=0;
namelength:=0;
split:=1;
more:=0;
indiff:=0;
outdiff:=0;
end;
end;

procedure expression(var expr:nodeptr);

var
first,stop:boolean;
exp:nodeptrs;

procedure repexpression(var expr:nodeptr);
begin
new(expr(*,'/'*));
with expr^ do
begin
art:='/';
expression(childs[true]);
if (token=']') or (token='-')
then empty(childs[false])
else begin
check('/');
expression(childs[false]);
end;
length:=maxi(childs[true]^.length, childs[false]^.length)+4;
split:=childs[false]^.split+childs[false]^.more+childs[true]^.split+1;
more:=childs[true]^.more;
indiff:=childs[true]^.indiff;
outdiff:=childs[true]^.outdiff;
end;
end;

procedure checklength(expr:nodeptr;l:integer;a:char);
begin
with expr^ do
if art=a then
begin
length:=l;
checklength(childs[true],l,a);
checklength(childs[false],l,a);
end;
end;

procedure alternativ(var exp:nodeptrs);
var
expr:nodeptr;
l1,l2:integer;
begin
new(expr(*,'!'*));
with expr^ do
begin
with exp[true]^ do
if art='!' then l1:=length-4
else l1:=length;
with exp[false]^ do
if art='!' then l2:=length-4
else l2:=length;
art:='!';
length:=maxi(l1,l2)+4;
split:=exp[true]^.split;
more:=exp[true]^.more+exp[false]^.split+exp[false]^.more+1;
indiff:=exp[true]^.indiff;
outdiff:=exp[true]^.outdiff;
checklength(exp[true],length,'!');
checklength(exp[false],length,'!');
childs:=exp;
end;
exp[true]:=expr;
end;

procedure break_line(var exp:nodeptrs);
var
expr:nodeptr;
l1,l2:integer;
begin
new(expr(*,'&'*));
with expr^ do
begin
with exp[true]^ do
if art='&' then l1:=length-4
else l1:=length;
with exp[false]^ do
if art='&' then l2:=length-4
else l2:=length;
art:='&';
length:=maxi(l1,l2)+4;
with exp[true]^ do l1:=split+more+2;
split:=l1;
with exp[false]^ do l2:=split+more+1;
more:=l2;
with exp[true]^ do l1:=indiff+more+2;
indiff:=l1;
with exp[false]^ do l2:=split+outdiff+1;
outdiff:=l2;
checklength(exp[true],length,'&');
checklength(exp[false],length,'&');
childs:=exp;
end;
exp[true]:=expr;
end;

procedure concatnate(var exp:nodeptrs);
var
expr:nodeptr;
l1,l2:integer;
begin
new(expr(*,'+'*));
with expr^ do
begin
art:='+';
length:=exp[true]^.length+exp[false]^.length+1;
with exp[true]^ do l1:=split+outdiff;
with exp[false]^ do l2:=split-indiff;
split:=maxi(l1,l2);
with exp[true]^ do l1:=more-outdiff;
with exp[false]^ do l2:=more+indiff;
more:=maxi(l1,l2);
with exp[true]^ do l1:=indiff+outdiff;
with exp[false]^ do l2:=indiff+outdiff;
indiff:=l1;
outdiff:=l2;
childs:=exp;
end;
exp[true]:=expr;
end;

begin (* expression *)
first:=true;
stop:=false;
repeat
  case token of
'a': terminal(exp[first]);
'<': begin
gettoken;
nonterminal(exp[first]);
check('>');
end;
'(': begin
gettoken;
expression(exp[first]);
check(')');
end;
'+','[': begin
gettoken;
repexpression(exp[first]);
if token='-' then token:=']';
check(']');
end;
'!': begin
gettoken;
if first then empty(exp[first]);
expression(exp[false]);
alternativ(exp);
first:=true;
end;
'&': begin
gettoken;
if first then empty(exp[first]);
expression(exp[false]);
break_line(exp);
first:=true;
end;
';','/',']','-',')': begin
if first then empty(exp[first]);
stop:=true;
first:=true;
end;
otherwise error(token,'?');
end;
if first
then first:=false
else concatnate(exp);
until stop or is_error;
expr:=exp[true];
end; (* expression *)

procedure writeframe(l:integer);
var i:integer;
begin
for i:=1 to l do write_ch('_');
moreframe:=false;
end;

procedure writequme(expr:nodeptr);
var i:integer;
begin
if moretimes=2 then
begin
morequme:=false;
with expr^ do
for i:=namestart to namestart+namelength-1 do
if i<=max then
if namebuffer[i]='^' then write_ch('*') else
if namebuffer[i]='*' then write_ch('X') else write_ch(' ')
else write_ch(' ')
end
else writeframe(expr^.namelength);
end;

procedure writenonterminal(expr:nodeptr);
var i:integer;
ch:char;
begin
if moretimes=0 then
begin
moreframe:=frame;
with expr^ do
for i:=namestart to namestart+namelength-1 do
if i<=max then
begin
 ch:=namebuffer[i];
 if (ch='*') or (ch='^') then
 begin  
  morequme:=qume;
  if ch='*' then ch:='+'; 
 end;
 write_ch(ch);
 if namebuffer[i]='*' then morequme:=qume;
end
else write_ch(' ')
end
else writequme(expr);
end;

procedure writeterminal(expr:nodeptr);
var i:integer;
ch:char;
begin
if moretimes=0 then
begin
moreframe:=frame;
with expr^ do
for i:=namestart to namestart+namelength-1 do
if i<=max then
begin
ch:=namebuffer[i];
if ('a'<=ch) and (ch<='z') then ch:=chr(ord(ch)+ord('A')-ord('a'));
write_ch(ch);
if ch='*' then morequme:=qume;
end
else write_ch(' ')
end
else writequme(expr);
end;

procedure writetree(expr:nodeptr; currentline:integer;
return:boolean; length:integer;
infillupch,infilldownch,outfillupch,outfilldownch:char);

var
ch:char;
fillch1,fillch2:array[boolean] of char;
fillch3:char;
i,fill_length:integer;

procedure find_fillch(line:integer;upch,downch:char;var ch1,ch2:char);
begin
if line=0 then
begin
ch1:=line_ch;
ch2:=line_ch;
end
else
begin
ch2:=' ';
if line<0 then ch1:=upch else ch1:=downch;
end;
end;

procedure writeblank(length:integer);
var i:integer;
begin
space_written:= space_written + length;
(*for i:=1 to length do write(list,' ');*)
end;

procedure writech(ch:char);
begin
if connection and (moretimes=0) then write_ch(ch) else write_ch(' ');
end;

procedure writefill(ch:char;before:boolean;framech:char);
var i:integer;
begin
if not before then
begin
if fill>=2 then writech(framech);
writech(ch);
for i:=3 to fill do writech(line_ch);
end else
begin
for i:=3 to fill do writech(line_ch);
writech(ch);
if fill>=2 then writech(framech);
end;
end;

begin
if (-expr^.split<=currentline) and (currentline<=expr^.more) then
begin
fill_length:=length-expr^.length;
find_fillch(currentline+expr^.indiff,infillupch,infilldownch,
fillch1[not return],fillch2[not return]);
find_fillch(currentline-expr^.outdiff,outfillupch,outfilldownch,
fillch1[return],fillch2[return]);
if currentline=0 then fillch3:=line_ch else fillch3:=' ';
if 2<=fill_length then
begin
writech(fillch1[true]);
infillupch:=' ';
outfillupch:=' ';
infilldownch:=' ';
outfilldownch:=' ';
end;
for i:=2 to fill_length div 2 do writech(fillch2[true]);
case expr^.art of
't':
if currentline=0 then
begin
if return then writefill(line_ch,true,frametermfirst)
else writefill('>',true,frametermfirst);
writeterminal(expr);
if return then writefill('<',false,frametermlast)
else writefill(line_ch,false,frametermlast);
end
else if (currentline=-1) and frame then
begin
writeblank(fill);
writeframe(expr^.namelength);
writeblank(fill);
end else
writeblank(expr^.namelength+2*fill);
'n':
if currentline=0 then
begin
if return then writefill(line_ch,true,framenonterm)
else writefill('>',true,framenonterm);
writenonterminal(expr);
if return then writefill('<',false,framenonterm)
else writefill(line_ch,false,framenonterm);
end
else if (currentline=-1) and frame then
begin
writeblank(fill);
writeframe(expr^.namelength);
writeblank(fill);
end
else writeblank(expr^.namelength+2*fill);
'e':
if currentline=0 then
begin
if return then writech('<')
else writech('>');
end
else writeblank(1);
'+':
begin
with expr^.childs[not return]^ do
if (-split<=currentline+outdiff) and (currentline+outdiff<=more) then
writetree(expr^.childs[not return],currentline+outdiff,return,length,
' ',' ',' ',' ')
else writeblank(length);
writech(fillch3);
with expr^.childs[return]^ do
if (-split<=currentline-indiff) and (currentline-indiff<=more) then
writetree(expr^.childs[return],currentline-indiff,return,length,
' ',' ',' ',' ')
else writeblank(length);
end;
'!':
with expr^ do
begin
writetree(childs[true],currentline,return,length,
infillupch,connectline,outfillupch,connectline);
writetree(childs[false],
currentline-childs[true]^.more-childs[false]^.split-1,
return,length,connectline,infilldownch,connectline,outfilldownch);
end;
'&':
with expr^ do
begin
writetree(childs[true],currentline+childs[true]^.more+2,return,length,
infillupch,' ',outfillupch,connectline);
if currentline=0 then for i:=1 to length do writech(line_ch);
if currentline=-1 then
begin
if return then writech(connectline);
writeblank(length-1);
if not return then writech(connectline);
end;
writetree(childs[false],currentline-childs[false]^.split-1,return,length,
connectline,infilldownch,' ',outfilldownch);
end;
'/':
begin
with expr^ do
begin
writetree(childs[false],
currentline+childs[false]^.more+childs[true]^.split+1,
not return,length,' ',connectline,' ',connectline);
writetree(childs[true],currentline,return,length,
connectline,' ',connectline,' ');
end;
end;
end;
for i:=2 to (fill_length+1) div 2 do writech(fillch2[false]);
if 1<=fill_length then writech(fillch1[false]);
end;
end;

  procedure hline(from_pos, to_pos: integer);
  begin
  if connection then
  begin
    writeln(list,' ');
    write(list,chr(1),'Ramme "3 0 ');
    if (pmargin<>pos_adjust) 
    then write(list,from_pos+pos_adjust)
    else write(list,'+',from_pos:1);
    write(list,to_pos-from_pos:4);
    write(list,' 0 "');
  end;
  end;
  
  procedure vline(pos, length: integer);
  begin
  if connection then
  begin
    writeln(list,' ');
    write(list,chr(1),'Ramme "3 0 ');
    if (pmargin<>pos_adjust)
    then write(list,pos+pos_adjust)
    else write(list,'+',pos:1);
    write(list,' 0 ',length:4);
    write(list,' "');
  end;
  end;
  
  procedure newpos(line: boolean; var linepos, pos: integer; addpos: integer);
  begin
    if line then
    begin
      if linepos<0 then linepos:=pos;
    end else
    begin
      if linepos>=0 then hline(linepos, pos);
      linepos:=-1;
    end;
    pos:=pos+addpos;
  end;

procedure writerammetree(expr: nodeptr; currentline:integer;
                         return: boolean; length: integer;
                         var linepos, pos:integer; vmade:boolean);
var line_in, line_out, fill_length, vlength:integer;
    help_expr: nodeptr;
    help_bool: boolean;

begin
if (-expr^.split<=currentline) and (currentline<=expr^.more) then
begin
if return then
begin line_in:= expr^.outdiff; line_out:= -expr^.indiff; end else
begin line_in:= -expr^.indiff; line_out:= expr^.outdiff end;
fill_length:=length-expr^.length;
newpos(currentline=line_in, linepos, pos, fill_length div 2);
case expr^.art of
't','n':
begin
  if (*return and*) ((pmargin*tpt) mod rctpt <> 0) then help:=1 else help:=0;
  if fill<2 then
  begin
    newpos(currentline=0, linepos, pos, fill);
    newpos(false, linepos, pos, expr^.namelength+help);
    if fill>help then
      newpos(currentline=0, linepos, pos, fill-help);
  end
  else begin
    if fill>=2 then
      newpos(currentline=0, linepos, pos, fill-1); 
    newpos(false, linepos, pos, expr^.namelength+2+help);
    if fill-1-help>0 then
    newpos(currentline=0, linepos, pos, fill-1-help);
  end;
end;
'e': newpos(currentline=0, linepos, pos, 1);
'+':
begin
with expr^.childs[not return]^ do
if (-split<=currentline+outdiff) and (currentline+outdiff<=more) then
writerammetree(expr^.childs[not return],currentline+outdiff,return,length,
linepos, pos, false)
else newpos(false, linepos, pos, length);
newpos(currentline=0, linepos, pos, 1);
with expr^.childs[return]^ do
if (-split<=currentline-indiff) and (currentline-indiff<=more) then
writerammetree(expr^.childs[return],currentline-indiff,return,length,
linepos, pos, false)
else newpos(false, linepos, pos, length);
end;
'!':
with expr^ do
begin
vlength:=childs[true]^.more;
help_expr:= childs[false];
while (help_expr^.art='!') and (length=help_expr^.length) do
begin
with help_expr^.childs[true]^ do
vlength:=vlength+split+more+1;
help_expr:=help_expr^.childs[false];
end;
vlength:=vlength+help_expr^.split+1;
if currentline=line_in then vline(pos,vlength-line_in-help_expr^.indiff);
writerammetree(childs[true],currentline,return,length,linepos, pos,
(childs[true]^.art='!') and (childs[true]^.length=length));
writerammetree(childs[false],
currentline-childs[true]^.more-childs[false]^.split-1,
return,length,linepos,pos,
(childs[false]^.art='!') and (childs[false]^.length=length));
if currentline=line_out then vline(pos,vlength+line_out+help_expr^.outdiff);
end;
'&':
with expr^ do
begin
if currentline=0 
then vline(pos, childs[false]^.split + 1 - childs[false]^.indiff);
writerammetree(childs[true],currentline+childs[true]^.more+2,return,length,
linepos, pos, false);
if currentline=0 then newpos(true, linepos, pos, length );
writerammetree(childs[false],currentline-childs[false]^.split-1,return,length,
linepos, pos, false);
if currentline=childs[true]^.outdiff-childs[true]^.more-2
then vline(pos,-currentline);
end;
'/':
begin
with expr^ do
begin
vlength:=childs[true]^.split+childs[false]^.more+1;
if currentline=line_in - vlength -childs[false]^.indiff 
then vline(pos, -currentline);
writerammetree(childs[false],
currentline+childs[false]^.more+childs[true]^.split+1,
not return,length,linepos, pos, false);
writerammetree(childs[true],currentline,return,length,
linepos, pos, false);
if currentline=line_out - vlength +childs[true]^.outdiff
then vline(pos, -currentline);
end;
end;
end;
newpos(currentline=line_out, linepos, pos, (fill_length+1) div 2 );
end;
end;

procedure writelineoftree(expr:nodeptr;line,length,out:integer);
var ramme_linepos, ramme_pos: integer;
begin
moreframe:=false;
morequme:=false;
moretimes:=0;
repeat
if moretimes>0 then
begin
write(list,cr);
if not moreframe then moretimes:=2;
end;
start_line(make_margin+indent);
(*for i:=1 to make_margin+indent do write(list,' ');*)
writetree(expr,line,false,length,' ',' ',' ',' ');
moretimes:=moretimes+1;
until not(moreframe or morequme) or is_error;
if (line=out) and connection then begin
write_ch('>');
end;
if rctekst then begin
ramme_linepos:=-1;
ramme_pos:= make_margin+indent+1;
writerammetree(expr,line,false,length,ramme_linepos,ramme_pos,false);
if (line=out) and connection then newpos(true, ramme_linepos, ramme_pos, 1);
newpos(false,ramme_linepos,ramme_pos,0);
end;
end;

begin (* rule *)
 defined:=false;
 if token='"' then comment else
 begin
  mark(new_ptr); 
  macro[0]:=chr(0);
  if token='$' then 
  begin
   gettoken;
   if token='a' then 
   begin
    if tokenlength>8 then tokenlength:=8;
    for i:=1 to 8 do
     if i<=tokenlength then macro[i]:=namebuffer[tokenstart-1+i]
     else macro[i]:=' ';
    macro[0]:=chr(tokenlength);
    tokenlength:=0;
   end;
  end;
  if len(macro)=0 then
  begin
   macro[0]:=chr(8);
   macro:='syndia  ';
   macro[8]:= chr((macro_no mod 10)+ord('0'));
   help:=macro_no div 10;
   if help<10 then macro[7]:=chr(help+ord('0'))
   else macro[7]:=chr(help-10+ord('A'));
   macro_no:=macro_no+1;
  end;
  if token='a' then terminal(lab)
  else empty(lab);
  check('<');
  nonterminal(left);
  if not is_error then
  begin
   write('rule: ');
   with left^ do
   begin
    for i:=namestart to namestart+namelength-1 do
    if i<=max then write(namebuffer[i])
    else write(' ');
    for i:=namelength to 30 do write(' ');
   end;
   if rctekst then write(', macro ',macro)
   else
   writeln;
   defined:=true;
   check('>');
   check('=');
   expression(rigth);
   check_page(2+rigth^.split+rigth^.more);
   morequme:=false;
   moreframe:=false;
   moretimes:=0;
   (* index *)
   if (def_free<def_max) and (name_def_free+left^.namelength<=name_def_max) then 
   begin
    def[def_free].page:= page_nr-1;
    def[def_free].namestart:=name_def_free;
    def[def_free].namelength:=left^.namelength;
    def[def_free].macro:= macro;
    for i:=left^.namestart to left^.namestart+left^.namelength-1 do
    begin
     name_def[name_def_free]:=namebuffer[i];
     name_def_free:=name_def_free+1;
    end;
    def_free:= def_free+1;
   end else def_overflow:= true;
   make_margin:=center - rigth^.length div 2 - fill - 1;
   if make_margin<left_margin then make_margin:= left_margin; 
   if rctekst then begin
    writeln(list,chr(22),'mk startdef ',macro);
    writeformat(tpt,lpt,'M');
    writeformat(rctpt,rclpt,'L');
    writeln(list,chr(10));
    writeln(list);
    (**)
    write(list,chr(14),chr(10)); 
    (**)
   end;
   
   if rcindex then begin
   space_written:= 0;
   write(list,chr(22),'so ');
   writenonterminal(left);
   writeln(list,':');
   end;
   start_line(make_margin);
   (*for i:=1 to make_margin do write(list,' ');*)
   (* 
   if rcindex then 
   begin
   write_ch(chr(191));
   write(list,chr(202+ord('S')-ord('A')));
   write(list,chr(202+ord('O')-ord('A')));
   
   for i:=1 to make_margin do write(list,' ');
   space_written:= 0;
   writeln(list);
   write_ch(chr(22));
   write_ch('s');
   write_ch('o');
   end;
   *)
   writenonterminal(left);
   (* if rcindex then write_ch(chr(190)); *) 
   write_ch(':');
   write_ch(' ');
   write_ch(' ');
   write_ch(' ');
   writeterminal(lab);
   if morequme then 
   begin
    write(list,cr);
    start_line(make_margin);
    (* for i:=1 to make_margin do write(list,' '); *)
    moretimes:=2;
    writenonterminal(left);
    write_ch(' ');
    write_ch(' ');
    write_ch(' ');
    writeterminal(lab);
   end;
   with rigth^ do
   begin
    for currentline:=-split to outdiff do
    begin
     writeln(list);
     writelineoftree(rigth,currentline,length+fill*2+2,outdiff);
    end;
    for currentline:=1+outdiff to more do
    begin
     writeln(list);
     writelineoftree(rigth,currentline,length+fill*2+2,outdiff);
    end;
    writeln(list);
   end;
   if rctekst then 
   begin
    (**)
    write(list,chr(15),chr(10)); 
    (**)
    writeln(list);
    writeln(list);
    writeln(list,chr(22),'mk sidsteformat');
    write(list,chr(22),'mk slutdef');
    writeln(list);
   end;
if fill=1 then i:=fill+2+make_margin+indent
else i:=fill+1+make_margin+indent;
if rigth^.length+i>linelength then
writeln(' !!!! warning line to long, length = ',rigth^.length:1)
;
end; (* ok *)
is_error:=false;
if not defined then writeln(' rule is undefined !!!!!');
writeln;
release(new_ptr);
tokenstart:=0;
tokenlength:=0;
end;
end;

procedure int_to_alfa(i:integer;var a:alfa);
var length,j:integer;
   sign:boolean;
begin
  if i<0 then length:=1
  else if i>0 then length:=0
  else length:=1;
sign:=i<0;
j:=abs(i);
  while j>0 do
  begin j:=j div 10; length:=length+1; end;
  for j:=length+1 to 12 do a[j]:=' ';
  for j:=length downto 1 do
  begin a[j]:=chr(i mod 10 + ord('0')); i:=i div 10; end;
 if sign then a[1]:='-';
end;

procedure system_param;
var str:string[255];
    command:string[12];
    help:string[12];
    str_pos,number:integer;
    found: boolean;
    i: integer;
    
  procedure param_number(var v: integer; default: integer);
  var h:integer;
  begin
    help:=copy(str,str_pos+1,len(str));
    val(help,h,str_pos);
    if h<1 then h:=default;
    if str_pos<>0 then
    begin
       param_error:=true; 
    end else v:=h;
  end;
  
  procedure param_boolean(var b: boolean);
  begin
    help:=copy(str,str_pos+1,len(str));
    if help='yes' then b:=true else
    if help='no' then b:=false else 
    begin param_error:=true; end;
  end;
  
begin
  found:=false;
  repeat
  if param_no>argcnt then 
  begin param_finis:= true; found:=true; end
  else begin
    str:=argstr(param_no);
    str_pos:=pos('=',str);
    if str_pos=0 then
    begin input_file:=str; found:=true;
      period_pos:=pos('.',input_file);
      if period_pos=0 then input_file:=concat(input_file,'.syn');
    end
    else if (str_pos>13) or (str_pos=1) then 
    begin param_error:= true; end
    else begin
      command:=copy(str,1,str_pos-1);
      for i:=1 to len(str) do
        if str[i]='_' then str[i]:=' ';
      if command='fill' then param_number(fill, d_fill) else
      if command='width' then  param_number(linelength, d_linelength) else
      if command='rcwidth' then  param_number(rcwidth, d_rcwidth) else
(*
      if command='length' then param_number(pagelength, d_pagelength) else
      if command='between' then param_number(line_space, d_line_space) else
      if command='head' then param_number(head, d_head) else
*)
      if command='rcmargin' then param_number(pmargin, d_pmargin) else
      if command='margin' then param_number(left_margin, d_left_margin) else
      if command='indent' then param_number(indent, d_indent) else
      if command='center' then param_number(center, d_center) else
 (*
      if command='title' then title:=copy(str,str_pos+1,len(str)) else
      if command='date' then date_v:=copy(str,str_pos+1,len(str)) else
      if command='time' then time_v:=copy(str,str_pos+1,len(str)) else
      if command='page' then begin
        param_number(page_nr, d_page_nr);
        if page_nr=0 then begin
          page_nr:=1;
          write_page_nr:= false;
        end else write_page_nr:=true;
      end else
 *)
      if command='connect' then param_boolean(connection) else
      if command='frame' then param_boolean(frame) else
 (*
      if command='qume' then param_boolean(qume) else
 *)
      if command='rctekst' then param_boolean(rctekst) else
      if command='rcindex' then param_boolean(rcindex) else
      if command='tpt' then param_number(tpt, d_tpt) else
      if command='lpt' then param_number(lpt, d_lpt) else
      if command='rctpt' then param_number(rctpt, d_rctpt) else
      if command='rclpt' then param_number(rclpt, d_rclpt) else
      begin param_error:= true; end;
    end;
  end;
  if param_error then
  begin
    writeln(output);
    writeln(output);
    writeln(output,' !!!!!!!!!!!!!            error in parameter: ',str);
    writeln(output);
    param_error:= false;
  end;
  param_no:=param_no+1;
  until found;
end;

(*
procedure system_param;
const
power12=4096;
equality=6;
point=8;
var
sep,int:integer;
i:integer;
alf:alfa;
begin
if param_no=1 then
if system(param_no,int,alf) div power12=equality then
begin
param_no:=param_no+1;
sep:=system(0,int,syntax_file);
if (sep mod power12)<>10  then syntax_file:='synlist';
end;
sep:=system(param_no,int,input_file);
if (sep mod power12)<>10 then
begin
if sep=0 then param_finis:=true
else param_error:=true;
param_no:=param_no+1;
input_file:='input';
end else
begin
param_no:=param_no+1;
sep:=system(param_no,int,alf);
if (sep div power12)=point then
if (input_file='fill') and ((sep mod power12)=4) then
begin
if int<1 then fill:=d_fill else fill:=int;
param_no:=param_no+1;
system_param;
end else
if (input_file='width') and ((sep mod power12)=4) then
begin
if int<1 then linelength:=d_linelength else linelength:=int;
param_no:=param_no+1;
system_param;
end else
if (input_file='length') and ((sep mod power12)=4) then
begin
if int<1 then pagelength:=d_pagelength else pagelength:=int;
param_no:=param_no+1;
system_param;
end else
if (input_file='head') and ((sep mod power12)=4) then
begin
if int<1 then head:=d_head else head:=int;
param_no:=param_no+1;
system_param;
end else
if (input_file='margin') and ((sep mod power12)=4) then
begin
if int<1 then left_margin:=d_left_margin else left_margin:=int;
param_no:=param_no+1;
system_param;
end else
if (input_file='indent') and ((sep mod power12)=4) then
begin
if int<1 then indent:=d_indent else indent:=int;
param_no:=param_no+1;
system_param;
end else
if (input_file='between') and ((sep mod power12)=4) then
begin
if int<1 then line_space:=d_line_space else line_space:=int;
param_no:=param_no+1;
system_param;
end else
if (input_file='title') then
begin
title_pos:=0;
for i:=1 to title_max do title[i]:=' ';
repeat
if (sep mod power12)=4 then
int_to_alfa(int,alf);
for i:=1  to 12 do
begin
if (alf[i]<>' ') and (title_pos<title_max) then
begin
title_pos:=title_pos+1;
title[title_pos]:=alf[i];
 end;
end;
if (title_pos<title_max) then
 begin
title_pos:=title_pos+1;
title[title_pos]:=' ';
end;
param_no:=param_no+1;
sep:=system(param_no,int,alf);
until (sep  div power12)<>point;
system_param;
end else
if (input_file='date') then
begin
  if (sep mod power12)=4 then
  begin
    if int=0 then date(date_v)
    else  int_to_alfa(int,date_v);
  end else date_v:=alf;
param_no:=param_no+1;
 system_param;
end else
if (input_file='time') then
begin
  if (sep mod power12)=4 then
  begin
    if int=0 then time(time_v)
    else int_to_alfa(int,time_v);
  end else time_v:=alf;
  param_no:=param_no+1;
  system_param;
end else
if (input_file='page') and ((sep mod power12)=4) then
begin
if int<1 then page_nr:=d_page_nr else page_nr:=int;
param_no:=param_no+1;
system_param;
end else
if (input_file='connect') and ((sep mod power12)=10) and
((alf='no') or (alf='yes')) then
begin
connection:=(alf='yes');
param_no:=param_no+1;
system_param;
end else
if (input_file='qume') and ((sep mod power12)=10) and
((alf='no') or (alf='yes')) then
begin
qume:=(alf='yes');
param_no:=param_no+1;
system_param;
end else
if (input_file='frame') and ((sep mod power12)=10) and
((alf='no') or (alf='yes')) then
begin
frame:=(alf='yes');
param_no:=param_no+1;
system_param;
end else
begin
param_error:=true;
param_no:=param_no+1;
input_file:='input';
end;
end;
end;
*)

function find_next_def: integer;
var next_def,next_length,next_start,index_def,j: integer;
    length: integer;
begin
  next_def:=0;
  while (def[next_def].page=0) and (next_def<def_free-1) do
  next_def:=next_def+1;
  next_start:=def[next_def].namestart;
  next_length:=def[next_def].namelength;
  for index_def:=1 to def_free-1 do
  with def[index_def] do
  if page<>0 then
  begin
    if next_length<=namelength then length:=next_length
    else length:=namelength;
    i:=0;
    while (i<length) and (name_def[i+next_start]=name_def[i+namestart])
    do i:=i+1;
    if ((i>=length) and (next_length>length)) or
       ((i<length) and (name_def[i+next_start]>name_def[i+namestart]))
    then begin
      next_def:=index_def;
      next_start:=namestart;
      next_length:=namelength;  
    end;
  end;
  if def[next_def].page=0 then find_next_def:=-1 else
  begin
    find_next_def:=next_def;
  end;
end;

begin
(* RC8000 initialize *)
nl:=chr(10);
cr:=chr(13);
macro_no:=0;
is_error:= false;
param_no:=1;
param_finis:=false;
param_error:=false;
syntax_file:='syndia.lst';
input_file:='KBD:';
fill:=d_fill;
pagelength:=d_pagelength;
linelength:=d_linelength;
head:=d_head;
left_margin:=d_left_margin;
pmargin:=d_pmargin;
make_margin:=d_left_margin;
indent:=d_indent;
center:=d_center;
line_space:=d_line_space;
title:='';
date_v:=d_date;
time_v:=d_time;
page_nr:=d_page_nr;
if page_nr=0 then begin
page_nr:=1;
write_page_nr:= false;
end else write_page_nr:=true;
connection:=true;
qume:=d_qume;
rctekst:=d_rctekst;
rcindex:=d_rcindex;
tpt:=d_tpt;
lpt:=d_lpt;
rctpt:=d_rctpt;
rclpt:=d_rclpt;
rcwidth:=d_rcwidth;
frame:=d_frame;
name_def_free:=0;
for def_free:=0 to def_max do def[def_free].page:=0;
def_free:=0;
def_overflow:= false;
system_param;
if input_file<>'KBD:' then 
begin
  period_pos:=pos('.',input_file);
  if period_pos=0 then period_pos:=len(input_file)
  else period_pos:=period_pos-1;
  syntax_file:=copy(input_file,1,period_pos);
  if rctekst then syntax_file:=concat(syntax_file,'.wp')
  else syntax_file:=concat(syntax_file,'.lst');
end;
writeln(' syntax diagrams printed on ',syntax_file);
writeln(' ***************************************');
writeln;
assign(list,syntax_file);
rewrite(list);
if rctekst then
begin
for i:=0 to 7 do write(list,chr(0));
write(list,chr(66));
write(list,chr(6));
write(list,chr(6));
write(list,'RC630',chr(0),chr(0),chr(0));
for i:=19 to 26 do write(list,chr(0));
write(list,chr(pmargin));
write(list,'N');
for i:=29 to 70 do write(list,chr(0));
writeformat(rctpt,rclpt,'L');
(*write(list,chr(10));*)
writeln(list,chr(22));
end;
repeat
line_ch:='-';
if qume then connectline:='*' else connectline:=chr(137) (*'!'*);
if rctekst then begin 
connectline:=' '; line_ch:=' ';
end;
if rctpt<=0 then help:=12 else help:=rctpt;
pos_adjust:= pmargin*( 119 div help + 1 );
if tpt<=0 then help:=12 else help:=tpt;
pos_adjust:= pos_adjust div (119 div help + 1);
if frame then
begin
frametermfirst:='(';
frametermlast:=')';
framenonterm:=connectline;
end else
begin
frametermfirst:=' ';
frametermlast:=' ';
framenonterm:=' ';
end;
writeln;
write(' syntax input from ',input_file);
lastch:=' ';
token:=' ';
tokenstart:=0;
lineno:=pagelength;
tokenlength:=0;
token:='.';
assign(input_f,input_file);
(*$I-*) reset(input_f) (*$I+*);
if iores>0 then writeln(', file does not exist') else gettoken; 
writeln;
writeln(' -------------------------------');
writeln;
while token<>'.' do
begin
rule;
if token=';' then gettoken;
end;
close(input_f);
system_param;
until param_finis;
line_space:=0;
lineno:=pagelength; (* new page *)
check_page(3);
if rctekst then
begin
  writeln(list,chr(22),'mk startdef drawall');
  for def_next:=0 to def_free-1 do
  with def[def_next] do
  begin
  write(list,chr(22),'** ');
  for name_def_free:=namestart to namestart+namelength-1
  do write(list,name_def[name_def_free]);
  writeln(list);
  writeln(list,chr(22),'ma ',macro);
  end;
  write(list,chr(22),'mk slutdef');
  writeln(list);
end else
begin
writeln(list);
if def_overflow then 
begin
  writeln(list,' ***************** INDEX table not complete ');
end else writeln(list);
writeln(list);
def_next:=find_next_def;
while (def_next>=0) do
with def[def_next] do
begin
  check_page(1);
  if left_margin>0 then write(list,' ':left_margin);
  for name_def_free:=namestart to namestart+namelength-1
   do write(list,name_def[name_def_free]);
  write(list,'  ');
  for name_def_free:=namelength to linelength-left_margin-20 
  do write(list,'.');
  writeln(list,page:5);
  page:=0;
  def_next:=find_next_def;
end;
end;
close(list);
end.