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) = <>; % % 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> 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 % 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 % % 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> 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;