reduce-historical/r36/mkhelp/comphelp.red

% comphelp.red:
%
%  first part of the REDUCE help compiler: syntax analysis
%   and structure generation.
%
%  the second part contains target specific code.
%
%  Author: Herbert Melenk, ZIB Berlin
%
%  November 1992
%

symbolic;

fluid '(char!* infile!* outfile!* !*windows !*test !*myeof);
fluid '(printfunction!* sect_count endchar current_node!*);
fluid '(!*verbatim !*sqbkt !*opennode currentfont topiccount!*);
fluid '(courier helvetica outc beginstack filestack level);
fluid '(nodechain undo match_point_lft match_point_rgt);
fluid '(run!* dir_src);
fluid '(aliases package);
fluid '(section_list regoup_sections);
fluid '(help_gensym_count);


run!* := 0;

% !*test := t;
regoup_sections := nil;

%------------------------------------------------------------
%
%  MAIN PROGRAM
%
%------------------------------------------------------------

symbolic procedure job(infile,outfile);
  begin  scalar !*raise, !*lower;
    help_gensym_count := 1;
    section_list := nil;
    !*myeof := nil;
    if getenv "echo" then !*echo:=t;
    run!* := run!* + 1;
    reset(); terpri();
    if run!* = 2 then update_labels();
    !*opennode := nil;
    sect_count:=1;
    topiccount!* := 0;
    printfunction!*:=nil;
    if infile!* then close infile!*;
    if outfile!* then close outfile!*;
    infile!*:=open(bldmsg("%w%w",dir_src,infile),'input);
    outfile!*:=open(outfile,'output);
    channellinelength(outfile!*,200);
    initoutput();
    newfont helvetica;
    mainloop();
    close_section 'document;
    write_sections();
    fontoff();
    endoutput();
    close infile!*;
    infile!* :=nil;
    if outfile!* then close outfile!*;
    outfile!*:=nil;
  % printstruct();
  end;

%------------------------------------------------------------
%
%  file input
%
%------------------------------------------------------------

fluid '(oldchar !*myecho !*myeof);

!*myecho := nil;
!*myeof := nil;

symbolic procedure rdch(); rdchr0(nil);

symbolic procedure rdch!*(); rdchr0(t);

symbolic procedure rdchr0(q);
 if !*myeof then !$eof!$ else
 if oldchar then <<oldchar := nil; old>> where old = oldchar
   else
 <<char!*:= channelreadch(infile!*);
   if !*myecho then prin2 char!*;
   if inf char!* = 9 then char!* := tab!* else  % tab
   if not q and prevchar neq '!\ and char!*='!% then
     <<while !$eol!$ neq channelreadch(infile!*) do nil;
       rdch()>>
        else char!*
 >> where prevchar = char!*;

symbolic procedure unrdch(); oldchar := char!*;

symbolic procedure myskip c;
     while (c neq rdch()) do nil;

symbolic procedure myskipl l;
   begin scalar c;
       while not memq(c:=rdch(),l) do nil;
       return c;
   end;

symbolic procedure myskipstring(s1,s2);
  begin scalar l,c,r;
    l:=explode2 s2;
    while l do
    <<c:=rdch(); r:=c.r;
      if c neq car l then
       error(99, {"EXPECTED:", {s1,s2},"FOUND:",{s1,reversip r}});
      l:=cdr l;
    >>;
  end;

fluid '(case!*);

case!*:= if '!N!I!L then 'lower else 'upper;

symbolic procedure mytoken(fold);
 begin scalar tok,c,n;
   tok:={'!"};
   while digit(c:=rdch()) or liter c do
      << n:=id2int c;
         if fold then
         if case!* = 'upper and n then
              c:=int2id(n-32)
         else if case!*='lower and 64<n and n<91 then
              c:=int2id(n+32);
        tok:=c.tok;
      >>;
     % if we have found a token, eat up the following blanks.
%  if cdr tok then while c='!  do c:=rdch();  % ACH: loses a char.
   if null cdr tok then return nil;
   tok := compress reverse('!".tok);
   return intern tok;
end;

symbolic procedure mystring();
 begin scalar tok,c;
   while digit(c:=rdch()) or liter c or c='!  or
	(endchar and c neq endchar) do
           tok:=c.tok;
   return reversip(tok);
end;

symbolic procedure mystring2();
  % read string util }, but ignore \}
 begin scalar tok,c;
   while (c:=rdch()) neq '!} do tok:=c.tok;
   return reversip(tok);
end;

symbolic procedure mystring2!]();
  % read string util ], but ignore \}
 begin scalar tok,c;
   while (c:=rdch!*()) neq '!] do tok:=c.tok;
   return reversip(tok);
end;

symbolic procedure mystring_nodename();
  % read node name, eventually updating the name translation table
  % for entries like "\begin{Command}[percent]{%}"
  % read string util }, but ignore \}
 begin scalar tok,c,alt;
   c:=myskipl '(!{ ![);
   if c='![ then
   << alt := mystring2!]();  myskip '!{ >>;
   while (c:=rdch!*()) neq '!} do tok:=c.tok;
   tok := reversip tok;
   if alt then aliases := (alt . tok) . aliases;
   return alt or tok;
end;

symbolic procedure mystring3();
 begin scalar tok,c;
  loop:
   c:=rdch();
   if c='!\ then <<tok := rdch().tok; goto loop>>;
   if c= '!}  then return reversip(tok);
   tok := c.tok; goto loop;
end;

symbolic procedure raisestring(s);
 begin scalar n;
  return for each c in s collect
   if (n:=id2int c)>95 then
        int2id(n-32) else c;
 end;

symbolic procedure lowerstring(s);
 begin scalar n;
  return for each c in s collect
   if liter c and (n:=id2int c)<95 then
        int2id(n+32) else c;
 end;

symbolic procedure mycompress u;
     compress reversip('!" . reverse('!" . u));

%---------------------- main loop ----------------------------

symbolic procedure mainloop();
  begin scalar u,c,tok,f,undo;
  loop:
    c:=rdch();
    if c=!$eof!$ then goto finis;
    if endchar and c=endchar then
    <<endchar:=nil; goto finis>>;
    if c='!{ then
     <<
      begin scalar endchar;
        endchar := '!};
        mainloop();
      end;
      goto loop;
     >>;
    if c='!\ then
    <<tok:=mytoken(t);
      if tok='ENDINPUT then <<!*myeof := t; goto finis>>;
      if null tok then
        <<c:=if char!*='!\ then !$eol!$ else c:=char!*;
          goto char>>;
      if tok='documentstyle then
         <<myskip('!}); goto loop>>
         else
      if tok='end then
         <<u:=mytoken(t);
           if !*test then <<prin2 " \end{"; prin2 u; prin2 "} ">>;
           if u neq car beginstack then
           <<prin2t {"****** begin(",car beginstack,
                     ") ended with end (",u,")"};
             exitlisp(1);
           >>;
           if !*test then printf(" (main pop %w)",beginstack);
           beginstack := cdr beginstack;
           goto finis>>
         else
      if(f:=get(tok,'act)) then
        <<
          if !*test then <<prin2 " \"; prin2 tok; prin2 " ">>;
          apply1(f,tok);
          if flagp(f,'simple) then oldchar := char!*;
          goto loop;
        >>
         else
         printf("**** unknown token: %w %n",tok);
    >>;
  char:
    if printfunction!* then apply1(printfunction!*,c);
    goto loop;
  finis:
    for each u in undo do eval(u);
  end;

%-----------------\input{...} \include{ ...}-----------------

symbolic procedure include(u);
  begin scalar file,fname,fname1,endchar;
    endchar := '!};
    fname:=mycompress mystring();
    if fname = "intro" then return;
    fname:=bldmsg("%w%w",dir_src,fname);
    endchar := nil;
    file:=errorset({'open,mkquote fname,mkquote 'input},nil,nil);
    if not errorp file then goto found;
    fname1:=bldmsg("%w.tex",fname);
    file:=errorset({'open,mkquote fname1,mkquote 'input},nil,nil);
    if not errorp file then goto found;
    printf("***** cannot open file >%w< resp. >%w< %n",fname,fname1);
    return nil;
  found:
    if fname1 then fname := fname1;
    filestack:=infile!*.filestack;
    infile!* :=car file;
    terpri(); prin2 "--- input file "; prin2t fname;
    mainloop();
    terpri(); prin2 "--- return from file "; prin2t fname;
    close infile!*;
    !*myeof := nil;
    infile!*:=car filestack;
    filestack := cdr filestack;
  end;

put('input,'act,'include);
put('include,'act,'include);

put('makeindex,'act,'null);
put('tt,'act,'null);

%-------------------section hierarchy -----------------------

symbolic procedure print_indent();
   if numberp level then for i:=1:level do prin2 "   ";

fluid '(record act_rec node_count);

node_count := 0;

smacro procedure type(u); car u;
smacro procedure seq(u); cadr u;
smacro procedure lab(u); caddr u;
smacro procedure count(u); cadddr u;
smacro procedure name(u);car cddddr u;

symbolic procedure reset();
  <<
   record :=
   {
    %  type        seq   lab  nr     name
      {'document,  nil,  "main_index",
                              1,     '(!T !o !p)},
%                             1,     "Top"},
      {'section,   nil,  nil, 1,     nil},
      {'subsection,nil,  nil, 1,     nil},
   {'subsubsection,nil,  nil, 1,     nil}};
   act_rec:= car record;
  >>;

symbolic procedure sectappend r;
    % link tail from next record to cont of first one
  car cdar r :=(cdr cadr r) . seq car r;

%-------------------- section -------------------------------


symbolic procedure section(s);
  begin scalar name;
    current_node!* := nil;
    name:=mystring2();
    close_section(s);
    open_section(s,name);
  end;

symbolic procedure close_section(s);
 begin scalar r;
   r:=record;
   while r and caar r neq s do r:= cdr r;
   if null r then  error({"record empty",s},99);
   for each u in reverse r do close_section1 u;
 end;

symbolic procedure close_section1(rec);
  if name rec then
  begin
     if !*windows then
     << print_indent(); reporttopic("               section end: ");
        terpri();
     >>;
     if regoup_sections then
          section_list := append(rec,nil) . section_list
       else
          write_section(rec);
     cdr rec:={nil,nil,0,nil};
  end;

symbolic procedure write_sections();
  for each s in section_list do write_section s;

symbolic procedure write_section(rec);
  if name rec then
  begin
     if !*opennode then emit_node_separator();
     !*opennode:=nil;
     emit_dir_new();
     emit_dir_label(lab rec);
     emit_dir_title name rec;
     emit_dir_browse('index,count rec);
     emit_dir_key(name rec);
     print_bold name rec;
     emit_dir_header();
     for each x in reverse seq rec do
       make_dir_entry (nil.x);
     emit_dir_separator();
  end;

symbolic procedure make_dir_entry rec;
    emit_dir_entry(name rec,lab rec);

symbolic procedure help_gensym();
  compress ('!g . explode2 (help_gensym_count := help_gensym_count+1));

symbolic procedure open_section(s,n);
   begin scalar r;
     sect_count:=sect_count+1;
     r:= record;
     while r and cdr r and caadr r neq s do r:=cdr r;
     if null r then  error({"record empty",s},99);
         % initialize new section and link to parent
     if not !*windows then n:=append(n, '(!  !s !e !c !t !i !o !n));
     cdr cadr r:={nil,help_gensym(),sect_count,n};
     sectappend r;
     r:= cadr r;
     level := if s='section then 0 else
              if s='subsection then 1 else
              if s='subsubsection then 2 else 3;
     print_indent();
     for each c in lowerstring explode2 s do prin2 c;
     prin2 " ";
     prin2 count r; prin2 " ";
     prin2 lab r; prin2 " ";
     mapc(name r,'prin2); terpri();
     act_rec := r;
     base_new_dir name r;
     level := if s='section then 1 else
              if s='subsection then 2 else
              if s='subsubsection then 3 else 4;
  end;

put('section,'act,'section);
put('subsection,'act,'section);
put('subsubsection,'act,'section);


%------------------- begin-end contexts ---------------------------

symbolic procedure beg(u);
  begin scalar tok,f,w;
    tok:=mytoken(t);
    for each c in beginstack do w:=w or (get(c,'context)='node);
    if w and 'node=get(tok,'context) then
     <<printf("===== missing end of node; hierarchy: %w",beginstack);
        exitlisp()>>;
    if !*test then <<terpri(); prin2 "\begin{"; prin2 tok;prin2 "}">>;
    if !*test then printf(" (push %w)",tok);
    beginstack := tok.beginstack;
    f:=get(tok,'context);
    if f then apply1(f,tok) else
    <<prin2t {"******* unknown begin-context:",tok};
      mainloop()>>;
  end;

put('begin,'act,'beg);

symbolic procedure mmain(u); mainloop();

put('document,'context,'mmain);

%------------------- generate unique labels  ----------------------

fluid '(labels!* l_list name_trans);

symbolic procedure clean_name u;
    if null u then nil else
    if car u memq '(!- !, !? !* !> !< !. ! )
      then '!_ . clean_name cdr u else
       car u . clean_name cdr u;


name_trans :='(
    ((!,) . COMMA_sign)
    ((!.) . DOT_sign)
    ((!;) . SEMICOLON_sign)
    ((!%) . PERCENT_sign)
    ((!$) . DOLLAR_sign)
    ((!: !=) . ASSIGN_sign)
    ((!=) . EQUAL_sign)
    ((!+) . PLUS_sign)
    ((!-) . MINUS_sign)
    ((!*) . TIMES_sign)
    ((!/) . SLASH_sign)
    ((!* !*) . POWER_sign)
    ((!$ !> != !$) . GEQ_sign)
    ((!> !=) . GEQ_sign)
    ((!>) . GREATER_sign)
    ((!$ !< != !$) . LEQ_sign)
    ((!< != ) . LEQ_sign)
    ((!<) . LESS_sign)
    ((!< !<) . BLOCK));


symbolic procedure make_label(name, type, alias);
   begin scalar u,s,w,uname;
    uname := raisestring name;
    if !*windows then
     << alias := clean_name alias;
        name := clean_name name>>;
    s := uname . type;
    u := assoc (s,labels!*);
    if u and run!* = 1 then
   <<prin2 " ######## duplicate node ";
     prin2 name;
     terpri();
   >>;
    if u then return cadr u;
    labels!* := (s.(w:=alias.name.type)). labels!*;
    if not member(uname,l_list) then
            l_list := uname . l_list;
    return car w;
  end;

symbolic procedure get_label name;
  (if l then car l) where l=get_label1 name;

symbolic procedure patch_ u;
  if null u then nil else
  if car u = '!_ then '!\ . '!_ . patch_ cdr u
   else car u . patch_ cdr u;

symbolic procedure get_label1 name;
  begin scalar u,uname;
   uname := raisestring name;
   u := get_label2 uname or get_label2 patch_ uname;
   if null u and (run!* > 1) then
   <<prin2 " ######## reference to ";
     prin2 name;
     prin2t "  not found,";
   >>;
   return if u then cdr u else nil;
  end;

symbolic procedure get_label2 uname;
  begin scalar u,uname;
   u := assoc((uname . 'operator),labels!*)
     or assoc((uname . 'function),labels!*)
     or assoc((uname . 'switch),labels!*)
     or assoc((uname . 'statement),labels!*)
     or assoc((uname . 'command),labels!*)
     or assoc((uname . 'declaration),labels!*)
     or assoc((uname . 'variable),labels!*)
     or assoc((uname . 'type),labels!*)
     or assoc((uname . 'constant),labels!*)
     or assoc((uname . 'concept),labels!*)
     or assoc((uname . 'package),labels!*)
     or assoc((uname . 'introduction),labels!*);
   return u;
  end;

symbolic procedure update_labels();
  % for unique names use the name as label.
  begin scalar new,old;
   terpri();
   prin2t "------ updating node labels -----";
   for each p in l_list do
    if (p:=get_label1 p) then
    <<old := car p; new := cadr p;
      car p := new;
      if nodechain then
        nodechain := substipq(new,old,nodechain);
    >>;
   prin2t "------ updating done ------------";
  end;

%------------------- nodes ------------------------------------

symbolic procedure node(type);
  begin scalar name,name2,rname,type2,name3,rec,type3,name4,label;
     scalar altname,alias;
     printfunction!* := 'textout;
     if !*opennode then emit_node_separator();
     !*opennode:=t;
     % myskip '!{;
     name:=mystring_nodename();
     if altname:=assoc(name,name_trans) then
       name := explode2 cdr altname;
%    alias := if !*windows and assoc(name,aliases) then
%         cdr assoc(name,aliases);
     alias := if assoc(name,aliases) then
          cdr assoc(name,aliases);
     type3 := lowerstring (type2:=explode2 type);
     name2 :=type . '!  . (rname:=raisestring name);
     name3 := append(type3,'!  . name);
     name4 := append(name, '!  . type3);
     label := make_label(name,type,name4);
     rec := {'node,
              nil,
              label,
              node_count:=add1 node_count,
              name4};
     car cdr act_rec:= cdr rec . seq act_rec;
     fonton();
     print_indent();
     mapc(name3,'prin2); reporttopic(" "); terpri();
     emit_node_label(lab  rec);
     emit_node_title(lab rec,name,type);
     emit_node_browse(lab act_rec,count rec);
     emit_node_keys(name4);
     current_node!* := name4;
     emit_hidden_node_key(type3);
     emit_hidden_node_key(name rec);
       % header line;
     myterpri();
     if alias  then <<print_bold alias; print_tab();>>;
     print_bold rname;
     if type2 neq '(C O N C E P T) then
     << print_tab(); print_tab(); print_tab(); print_tab();
        print_bold type2;
     >>;
     print_newline();  second_newline();
     mainloop ();
  end;

put('switch,'context,'node);
put('variable,'context,'node);
put('operator,'context,'node);
put('function,'context,'node);
put('command,'context,'node);
put('statement,'context,'node);
put('declaration,'context,'node);
put('concept,'context,'node);
put('introduction,'context,'node);
put('package,'context,'node);
put('type,'context,'node);
put('constant,'context,'node);


symbolic procedure part(type);
   begin
     outc:='! ;
     if type='examples or type='syntax or type='related
            then par_heading(type) else
     if type='bigexample then par_heading('example);

     if type='bigexample or type='verbatim then return vpart(type) else
     if type='examples then return examples_part(type);
     if type='syntax or type='examples then newfont courier;
     mainloop();
     second_newline(); second_newline();
     newfont helvetica;
    end;

symbolic procedure par_heading(type);
 <<verbprin2 !$eol!$;
   for each x in explode type do verbprin2 x;
   verbprin2 ":";
   verbprin2 !$eol!$; verbprin2 !$eol!$;
 >>;

symbolic procedure vpart(type);
  % formatted / verbatim part.
  begin
     emit_start_verbatim();
     set_tab();
     newfont courier;

     vpart0();

     emit_end_verbatim();
     newfont helvetica;
   end;

symbolic procedure vpart0();
  begin scalar c,c1,c2,c3;
  loop:
    c:=rdch();
    if c=!$eof!$ then rederr "#### EOF in verbatim part";
    if c='!\ then
    <<c2:=c3:=nil;
      if (c1:=rdch()) = '!\ then <<verbprin2 !$eol!$; goto loop>>;
      if c1 = '!e and (c2:=rdch()) = '!n and (c3:=rdch()) = '!d
         then goto done;
      verbprin2 '!\; verbprin2 c1;
      if c2 then verbprin2 c2;
      if c3 then verbprin2 c3;
      goto loop>>;
    verbprin2 c;
    goto loop;
done:
     rdch();
     mytoken(t);
     if !*test then printf(" (vpart pop %w)",beginstack);
     beginstack := cdr beginstack;
     release_tab();
   end;

symbolic procedure compareahead(seq,l); compareahead1(seq,cdr seq,l);

symbolic procedure compareahead1(base,seq,l);
   if null l then t else
   if null seq then compareahead1(nconc(base,c),c,l) where c={rdch()}
    else
   if not(car seq = car l) then nil else
        compareahead1(base,cdr seq,cdr l);

macro procedure  look_ahead(m);
    {'compareahead,'inlist,mkquote explode2 cadr m};

symbolic procedure examples_part(type);
  % formatted / verbatim part.
  begin scalar c,pg,state,tab_flag,pg,ll,l,endflag,eolflag,inlist;
     emit_start_verbatim();
     set_tab();
     newfont courier;
     state := 'lhs;
  read_next:
    eolflag := nil;
    ll := nil;
  read_loop:
    c:=rdch();
    if c=!$eof!$ then rederr "#### EOF in examples part";
    if c='!\ then
    <<inlist :={nil};
      if look_ahead "\" then
           <<eolflag := t;
             if state = 'rhs then goto rhs_line
                 else goto tab_label>>;
      if look_ahead "end{Examples}"
         then <<endflag := t;
                if !*test then prin2t "\end{Examples}";
                if state = 'rhs then goto rhs_line else goto done;
              >>
        else
      if look_ahead "explanation"
         then << myskip '!{;
                 non_verb_block() where endchar='!};
                 goto read_next;
              >>        else
      if look_ahead "begin{multilineinput}"
         then <<
                 beginstack := 'multilineinput.beginstack;
                 vpart0();
                 goto read_next;
              >>;
      if state neq 'rhs and look_ahead "begin{multilineoutput}"
         then <<
                 beginstack := 'multilineoutput.beginstack;
                 vpart0();
                 goto read_next;
              >>;
      ll := '!\ . ll;
      for each q in cdr inlist do if q then ll := q . ll;
      goto read_loop
    >>
    else if c='!& then
     <<if state = 'lhs then goto tab_label else
       <<mapc(reverse ll,'prin2); rederr "#### second & in example">>
     >>
    else ll := c . ll;
    goto read_loop;
tab_label:
    while ll and cdr ll and car ll = '!  and cadr ll = '!  do
      ll := cdr ll;  % remove trailing blanks.
    l := reversip ll;
    for each c in l do
    %  if not c=!$eol!$ then
         verbprin2 c;
    if eolflag then
    <<verbprin2 !$eol!$; goto read_next>>;
    if length l > 35 then verbprin2 !$eol!$;
 %% verbprin2 '!&;
 %% verbprin2 "=>";
    state := 'rhs;
    goto read_next;

 rhs_line:
    verbprin2 !$eol!$;
    ll:=reversip ll;
       % remove leading blanks
    ll := delete(!$eol!$,ll);
    while ll and car ll = '!  do ll:= cdr ll;

   goto no_expla;
    if matchleft(ll,'(!\ !e !x !p !l !a !n !a))
     then
     <<while ll and not (car ll = '!{) do ll := cdr ll;
       ll:= cdr ll;
       newfont helvetica;
       while ll and not(car ll = '!}) do
        <<textout car ll;ll:= cdr ll>>;
       ll := cdr ll;
     >>;

   no_expla:
     % provide for multiline
    if matchleft(ll,'(!\ !b !e !g !i !n
                    !{ !m !u !l !t !i !l !i !n !e !o !u !t !p !u !t !}))
    then pg:=make_multi_out() ELSE pg:=minitex ll;

    if null pg then goto nix;
    tab_flag :=  t;
 %% if cadr pg > 35 then
    <<verbprin2 !$eol!$; verbprin2 "  "; tab_flag := nil>>;
    pg := cddr pg;
    while pg do
    <<l := car pg; pg := cdr pg;
      for each c in l do verbprin2 c;
      if pg then
      <<verbprin2 !$eol!$;
        if tab_flag then verbprin2 '!&;
        verbprin2 "  ";
      >>;
    >>;
    verbprin2 !$eol!$;
  nix:
    verbprin2 !$eol!$;
    state := 'lhs;
    if endflag then goto done;
    goto read_next;

done:
    emit_end_verbatim();
     if !*test then printf(" (examples pop %w)",beginstack);
     beginstack := cdr beginstack;
     release_tab();
     newfont helvetica;
   end;

symbolic procedure non_verb_block();
  begin
   emit_end_verbatim();
   release_tab();
   newfont helvetica;
   mainloop ();
   newfont courier;
   set_tab();
   emit_start_verbatim();
  end;

symbolic procedure make_multi_out();
 begin scalar con,w,pg,m,q;
       con:=t;
       w := cdr match_point_rgt;
         % get rid of "{6cm}"
       while w and car w neq '!} do w:=cdr w;
       if w then w:=cdr w;
       if member(!$eol!$,w) then
       <<q:=cut_lines(w,nil); w:= car q; q:=cdr q>>;
       pg:=nil;
       m:=0;
   mult_loop:
       match_point_lft:=nil;
       if matcharb(w, '(!\ !e !n !d !{ !m !u !l !t !i !l !i !n !e ))
       then<< con:=nil;
              if match_point_lft then cdr match_point_lft:=nil else w:=nil;
           >>;
       if w then
          <<if length w>m then m:=length w;
              if memq('!^,w) or memq('!{,w) then
                pg := append(pg,cddr minitex w)
                  else
                pg:=append(pg,{w})
          >>;
       if con then
       <<
         if q then <<w:=car q;q:=cdr q>> else w:=read_one_line();
         goto mult_loop
       >>;
       pg := length pg . m . pg;
       return pg;
    end;

symbolic procedure cut_lines(l,q);
    if null l then {reversip q} else
    if car l = !$eol!$ then reversip q . cut_lines(cdr l,nil)
    else cut_lines(cdr l,car l . q);

%   match_point_lft:  pair before match position
%   match_point_rgt:  last pair of matched string

symbolic procedure matchleft(a,pat);
  if null pat then t else
  if null a then nil else
  if car a neq car pat then
       <<match_point_lft:=a; nil>>
   else <<match_point_rgt:=a;
          matchleft(cdr a,cdr pat)>>;

symbolic procedure matcharb(a,pat);
  if null a then nil else
  matchleft(a,pat) or matcharb(cdr a,pat);

symbolic procedure read_one_line();
  begin scalar l,c;
 loop:
   c := rdch();
   if c=!$eol!$ then return reversip l;
   l := c.l;
   goto loop;
  end;

put('comments,'context,'part);
put('examples,'context,'part);
put('bigexample,'context,'part);
put('syntax,'context,'part);
put('related,'context,'part);
put('text,'context,'part);
put('verbatim,'context,'part);
put('quote,'context,'part); % QUOTE -> VERBATIM (temporal)

symbolic procedure do!-itemize(type);
   begin
     outc:='! ;
     mainloop();
     second_newline();
    end;

put('itemize,'context,'do!-itemize);

symbolic procedure context_error(p,q);
  <<
    terpri();
    prin2 "######### error in context ";
    prin2 p;
    prin2 " ### : ";
    prin2t q;
  >>;

%-------------------- special item routines ----------------------

symbolic procedure verb(u);
  begin scalar endchar,!*verbose;
     endchar := char!*; !*verbose:=t;
     mainloop();
  end;
put('verb,'act,'verb);

symbolic procedure ldots(u); textout "...";
put('ldots,'act,'ldots);
flag('(ldots),'simple);

symbolic procedure cdots(u); textout "...";
put('cdots,'act,'cdots);
flag('(cdots),'simple);

symbolic procedure cdot(u); textout ". ";
put('cdot,'act,'cdot);
flag('(cdot),'simple);


symbolic procedure write_pi(u); textout "pi";
put('pi,'act,'write_pi);
flag('(write_pi),'simple);

symbolic procedure emphase(u); printem mystring3();
put('key,'act,'emphase);

symbolic procedure meta(u);
    <<textout "<"; mapc(mystring2(),'textout); textout ">">>;

put('meta,'act,'meta);

symbolic procedure italic(u);
   <<switchitalic(t);
     unrdch();
     undo := '(switchitalic nil).undo>>;
symbolic procedure switchitalic u; nil;
put('bf,'act,'italic);
put('em,'act,'italic);
put('it,'act,'italic);

symbolic procedure nameref(u); printnameref mystring3();
put('nameref,'act,'nameref);

symbolic procedure ref(u); printref mystring2();
put('ref,'act,'ref);

symbolic procedure see(u);
     begin
       u:=mystring2();
    %  textout2 u; textout '! ;
       emit_node_key u;
     end;

put ('see,'act,'see);

symbolic procedure myname(u);
    printem mystring3();
put ('name,'act,'myname);

symbolic procedure myindex(u);
     <<textout '! ;emit_node_key mystring2()>>;
put('index,'act,'myindex);

symbolic procedure nameindex(u);
    begin scalar s;
      s:= mystring2();
      textout '! ;
      emit_hidden_node_key s;
      printem s;
    end;
put('nameindex,'act,'nameindex);

symbolic procedure reduce(u); textout "REDUCE";
put('reduce,'act,'reduce);
flag('(reduce),'simple);

symbolic procedure rept(u); textout "+";
put('repeated,'act,'rept);
flag('(rept),'simple);

symbolic procedure optional(u); textout "*";
put('optional,'act,'optional);
flag('(optional),'simple);

symbolic procedure myexp(u); <<textout"(";textout "exp">>;
put('exp,'act,'myexp);

symbolic procedure formula(u); textoutl mystring2();
put('variable,'act,'formula);
put('arg,'act,'formula);

symbolic procedure rfrac(u);
   <<textoutl mystring2();
     rdch();
     textout "/";
     textoutl mystring2();
   >>;
put('rfrac,'act,'rfrac);

symbolic procedure item(u);
   begin scalar endchar;
     endchar := '!];
     print_newline();
     if !*windows then print_tab();
     mainloop();
  end;

put('item,'act,'item);

%-------------------- support for iftex etc. ---------------------

symbolic procedure texonly1(u);
   begin scalar endchar,c;
    integer count;
    count:=1;
  loop:
    c:= rdch();
    if c='!\ then c:= rdch() else
    if c='!{ then count:=count+1 else
    if c='!} then count:=count-1;
    if count>0 then goto loop;
    myskip('!{);
    endchar:='!};
    mainloop();
  end;

put('iftex,'act,'texonly1);

symbolic procedure texonly2(u);
   begin scalar endchar,c,tok;
    integer count;
    count:=1;
  loop:
    c:= rdch();
    if c='!\ then
    <<tok:=mytoken(t);
      if tok='begin then count:=count+1 else
      if tok='end then count:=count-1;
    >>;
    if count>0 then goto loop;
    tok:=mytoken(t);
    if tok neq 'tex then
    <<printf("****** \begin{tex} ends with \end{%w}%n",tok);
      exitlisp();
    >>;
    if !*test then printf(" (texonly pop %w)",beginstack);
    beginstack := cdr beginstack;
  end;

put('tex,'context,'texonly2);

symbolic procedure infoonly(u);
   begin scalar endchar;
     mainloop();
   end;

put('info,'context,'infoonly);

symbolic procedure reporttopic u;
   if !*windows then
    <<prin2 u; prin2(topiccount!* := topiccount!*+1); prin2 " ">>;

%----------------- untilities ------------------------------

symbolic procedure substipq(new,old,l);
  % destructive substip based on eq test.
   if not pairp l then l else
   <<
     if car l eq old then car l := new;
     if cdr l eq old then cdr l := new;
     substipq(new,old,car l);
     substipq(new,old,cdr l);
     l>>;

end;