Artifact f90e8542b4c4d188b5f3a9b38a69b7df2333965b7cc5ea738eb53246ad0813d7:
- Executable file
r36/src/pretty.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 12497) [annotate] [blame] [check-ins using] [more...]
module pretty; % Print list structures in an indented format. % Author: A. C. Norman, July 1978. create!-package('(pretty),'(util)); fluid '(bn bufferi buffero indblanks indentlevel initialblanks lmar pendingrpars rmar rparcount stack); global '(!*quotes !*symmetric thin!*); !*symmetric := t; !*quotes := t; thin!* := 5; % This package prints list structures in an indented format that % is intended to make them legible. There are a number of special % cases recognized, but in general the intent of the algorithm % is that given a list (R1 R2 R3 ...), SUPERPRINT checks if % the list will fit directly on the current line and if so % prints it as: % (R1 R2 R3 ...) % if not it prints it as: % (R1 % R2 % R3 % ... ) % where each sublist is similarly treated. % % Functions: % SUPERPRINTM(X,M) print expression X with left margin M % PRETTYPRINT(X) = <<superprintm(x,posn()); terpri(); terpri()>>; % % Flag: % !*SYMMETRIC If TRUE, print with escape characters, % otherwise do not (as PRIN1/PRIN2 % distinction). defaults to TRUE; % !*QUOTES If TRUE, (QUOTE x) gets displayed as 'x. % default is TRUE; % % Variable: % THIN!* if THIN!* expressions can be fitted onto % a single line they will be printed that way. % this is a parameter used to control the % formatting of long thin lists. default % value is 5; symbolic procedure prettyprint x; << superprinm(x,posn()); %WHAT REDUCE DOES NOW; terpri(); nil>>; symbolic procedure superprintm(x,lmar); << superprinm(x,lmar); terpri(); x >>; % From here down the functions are not intended for direct use. % The following functions are defined here in case this package % is called from LISP rather than REDUCE. symbolic procedure eqcar(a,b); pairp a and car a eq b; symbolic procedure spaces n; for i:=1:n do prin2 '! ; % End of compatibility section. symbolic procedure superprinm(x,lmar); begin scalar stack,bufferi,buffero,bn,initialblanks,rmar, pendingrpars,indentlevel,indblanks,rparcount,w; bufferi:=buffero:=list nil; %fifo buffer. initialblanks:=0; rparcount:=0; indblanks:=0; rmar:=linelength(nil) - 3; %right margin. if rmar<25 then error(0,list(rmar+3, "Linelength too short for superprinting")); bn:=0; %characters in buffer. indentlevel:=0; %no indentation needed, yet. if lmar+20>=rmar then lmar:=rmar - 21; %no room for specified margin w:=posn(); if w>lmar then << terpri(); w:=0 >>; if w<lmar then initialblanks:=lmar - w; prindent(x,lmar+3); %main recursive print routine. % traverse routine finished - now tidy up buffers. overflow 'none; %flush out the buffer. return x end; % Access functions for a stack entry. smacro procedure top; car stack; smacro procedure depth frm; car frm; smacro procedure indenting frm; cadr frm; smacro procedure blankcount frm; caddr frm; smacro procedure blanklist frm; cdddr frm; smacro procedure setindenting(frm,val); rplaca(cdr frm,val); smacro procedure setblankcount(frm,val); rplaca(cddr frm,val); smacro procedure setblanklist(frm,val); rplacd(cddr frm,val); smacro procedure newframe n; list(n,nil,0); smacro procedure blankp char; numberp car char; symbolic procedure prindent(x,n); % Print list x with indentation level n. if atom x then if vectorp x then prvector(x,n) else for each c in (if !*symmetric then if stringp x then explodes x else explode x else explode2 x) do putch c else if quotep x then << putch '!'; prindent(cadr x,n+1) >> else begin scalar cx; if 4*n>3*rmar then << %list is too deep for sanity. overflow 'all; n:=n/8; if initialblanks>n then << lmar:=lmar - initialblanks+n; initialblanks:=n >> >>; stack := (newframe n) . stack; putch ('lpar . top()); cx:=car x; prindent(cx,n+1); if idp cx and not atom cdr x then cx:=get(cx,'ppformat) else cx:=nil; if cx=2 and atom cddr x then cx:=nil; if cx='prog then << putch '! ; prindent(car (x:=cdr x),n+3) >>; % CX now controls the formatting of what follows: % nil default action % <number> first few blanks are non-indenting % prog display atoms as labels. x:=cdr x; scan: if atom x then go to outt; finishpending(); %about to print a blank. if cx='prog then << putblank(); overflow bufferi; %force format for prog. if atom car x then << % a label. lmar:=initialblanks:=max(lmar - 6,0); prindent(car x,n - 3); % print the label. x:=cdr x; if not atom x and atom car x then go to scan; if lmar+bn>n then putblank() else for i:=lmar+bn:n - 1 do putch '! ; if atom x then go to outt>> >> else if numberp cx then << cx:=cx - 1; if cx=0 then cx:=nil; putch '! >> else putblank(); prindent(car x,n+3); x:=cdr x; go to scan; outt: if not null x then << finishpending(); putblank(); putch '!.; putch '! ; prindent(x,n+5) >>; putch ('rpar . (n - 3)); if indenting top()='indent and not null blanklist top() then overflow car blanklist top() else endlist top(); stack:=cdr stack end; symbolic procedure explodes x; %dummy function just in case another format is needed. explode x; symbolic procedure prvector(x,n); begin scalar bound; bound:=upbv x; % length of the vector. stack:=(newframe n) . stack; putch ('lsquare . top()); prindent(getv(x,0),n+3); for i:=1:bound do << putch '!,; putblank(); prindent(getv(x,i),n+3) >>; putch('rsquare . (n - 3)); endlist top(); stack:=cdr stack end; symbolic procedure putblank(); begin putch top(); %represents a blank character. setblankcount(top(),blankcount top()+1); setblanklist(top(),bufferi . blanklist top()); %remember where I was. indblanks:=indblanks+1 end; symbolic procedure endlist l; %Fix up the blanks in a complete list so that they %will not be turned into indentations. pendingrpars:=l . pendingrpars; % When I have printed a ')' I want to mark all of the blanks % within the parentheses as being unindented, ordinary blank % characters. It is however possible that I may get a buffer % overflow while printing a string of )))))))))), and so this % marking should be delayed until I get round to printing % a further blank (which will be a candidate for a place to % split lines). This delay is dealt with by the list % pendingrpars which holds a list of levels that, when % convenient, can be tidied up and closed out. symbolic procedure finishpending(); << for each stackframe in pendingrpars do << if indenting stackframe neq 'indent then for each b in blanklist stackframe do << rplaca(b,'! ); indblanks:=indblanks - 1>>; % blanklist of stackframe must be non-nil so that overflow % will not treat the '(' specially. setblanklist(stackframe,t) >>; pendingrpars:=nil >>; symbolic procedure quotep x; !*quotes and not atom x and car x='quote and not atom cdr x and null cddr x; % property ppformat drives the prettyprinter - % prog : special for prog only % 1 : (fn a1 % a2 % ... ) % 2 : (fn a1 a2 % a3 % ... ) ; put('prog,'ppformat,'prog); put('lambda,'ppformat,1); put('lambdaq,'ppformat,1); put('setq,'ppformat,1); put('set,'ppformat,1); put('while,'ppformat,1); put('t,'ppformat,1); put('de,'ppformat,2); put('df,'ppformat,2); put('dm,'ppformat,2); put('foreach,'ppformat,4); % (foreach x in y do ...) etc. % Now for the routines that buffer things on a character by character % basis, and deal with buffer overflow. symbolic procedure putch c; begin if atom c then rparcount:=0 else if blankp c then << rparcount:=0; go to nocheck >> else if car c='rpar then << rparcount:=rparcount+1; % format for a long string of rpars is: % )))) ))) ))) ))) ))) ; if rparcount>4 then << putch '! ; rparcount:=2 >> >> else rparcount:=0; while lmar+bn>=rmar do overflow 'more; nocheck: bufferi:=cdr rplacd(bufferi,list c); bn:=bn+1 end; symbolic procedure overflow flg; begin scalar c,blankstoskip; %the current buffer holds so much information that it will %not all fit on a line. try to do something about it. % flg is one of: % 'none do not force more indentation % 'more force one level more indentation % <a pointer into the buffer> % prints up to and including that character, which % should be a blank. if indblanks=0 and initialblanks>3 and flg='more then << initialblanks:=initialblanks - 3; lmar:=lmar - 3; return 'moved!-left >>; fblank: if bn=0 then << % No blank found - can do no more for now. % If flg='more I am in trouble and so have to print % a continuation mark. in the other cases I can just exit. if not(flg = 'more) then return 'empty; if atom car buffero then % continuation mark not needed if last char printed was % special (e.g. lpar or rpar). prin2 "%+"; %continuation marker. terpri(); lmar:=0; return 'continued >> else << spaces initialblanks; initialblanks:=0 >>; buffero:=cdr buffero; bn:=bn - 1; lmar:=lmar+1; c:=car buffero; if atom c then << prin2 c; go to fblank >> else if blankp c then if not atom blankstoskip then << prin2 '! ; indblanks:=indblanks - 1; % blankstoskip = (stack-frame . skip-count). if c eq car blankstoskip then << rplacd(blankstoskip,cdr blankstoskip - 1); if cdr blankstoskip=0 then blankstoskip:=t >>; go to fblank >> else go to blankfound else if car c='lpar or car c='lsquare then << prin2 get(car c,'ppchar); if flg='none then go to fblank; % now I want to flag this level for indentation. c:=cdr c; %the stack frame. if not null blanklist c then go to fblank; if depth c>indentlevel then << %new indentation. % this level has not emitted any blanks yet. indentlevel:=depth c; setindenting(c,'indent) >>; go to fblank >> else if car c='rpar or car c='rsquare then << if cdr c<indentlevel then indentlevel:=cdr c; prin2 get(car c,'ppchar); go to fblank >> else error(0,list(c,"UNKNOWN TAG IN OVERFLOW")); blankfound: if eqcar(blanklist c,buffero) then setblanklist(c,nil); % at least one entry on blanklist ought to be valid, so if I % print the last blank I must kill blanklist totally. indblanks:=indblanks - 1; % check if next level represents new indentation. if depth c>indentlevel then << if flg='none then << %just print an ordinary blank. prin2 '! ; go to fblank >>; % here I increase the indentation level by one. if blankstoskip then blankstoskip:=nil else << indentlevel:=depth c; setindenting(c,'indent) >> >>; %otherwise I was indenting at that level anyway. if blankcount c>(thin!* - 1) then << %long thin list fix-up here. blankstoskip:=c . ((blankcount c) - 2); setindenting(c,'thin); setblankcount(c,1); indentlevel:=(depth c) - 1; prin2 '! ; go to fblank >>; setblankcount(c,(blankcount c) - 1); terpri(); lmar:=initialblanks:=depth c; if buffero eq flg then return 'to!-flg; if blankstoskip or not (flg='more) then go to fblank; % keep going unless call was of type 'more'. return 'more; %try some more. end; put('lpar,'ppchar,'!(); put('lsquare,'ppchar,'![); put('rpar,'ppchar,'!)); put('rsquare,'ppchar,'!]); endmodule; end;