Artifact 9e887f66675c16ff429acdf5386a7cafbc89a8e7d9fb0d510623d16746c0ed6d:
- File
r36/mkhelp/comphelp.red
— part of check-in
[152fb3bdbb]
at
2011-10-17 17:58:33
on branch master
— svn:eol-style, svn:executable and line endings for files
in historical/r36 treegit-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1480 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: schoepf@users.sourceforge.net, size: 28616) [annotate] [blame] [check-ins using] [more...]
% 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;