@@ -1,1081 +1,1081 @@
-% 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;
-
-
+% 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;
+
+