% <PSL.UTIL>PRETTY.RED.2, 2-Sep-82 09:16:32, Edit by BENSON
% PRETTYPRINT returns NIL instead of its argument
% 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.
%
% A. C. Norman. July 1978;
% Functions:
% SUPERPRINT(X) print expression X
% SUPERPRINTM(X,M) print expression X with left margin M
% PRETTYPRINT(X) = << SUPERPRINTM(X,POSN()), 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;
GLOBAL '(!*SYMMETRIC !*QUOTES THIN!*);
!*SYMMETRIC:=T;
!*QUOTES:=T;
THIN!*:=5;
SYMBOLIC PROCEDURE SUPERPRINT X;
<< SUPERPRINM(X,0); TERPRI(); X>>;
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;
FLUID '(STACK BUFFERI BUFFERO BN LMAR RMAR INITIALBLANKS
PENDINGRPARS INDENTLEVEL INDBLANKS RPARCOUNT);
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;
CompileTime <<
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 EXPLODEC X) DO PUTCH C
ELSE IF READMACROP X THEN <<
FOR EACH C IN GET(CAR X,'READMACROTOKEN) DO
PUTCH C;
PRINDENT(CADR X,N+GET(CAR X,'READMACROSIZE)) >>
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 OUTL;
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 OUTL >> >>
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;
OUTL: 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 '!,; % removed "," between vector elements for PSL
PUTBLANK();
PRINDENT(GETV(X,I),N+3) >>;
PUTCH('RSQUARE . (N-3));
ENDLIST TOP();
STACK:=CDR STACK
END;
SYMBOLIC PROCEDURE PUTBLANK();
BEGIN
SCALAR B;
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 READMACROP X;
!*QUOTES AND
NOT ATOM X AND
IDP CAR X AND
GET(CAR X,'READMACROTOKEN) AND
NOT ATOM CDR X AND
NULL CDDR X;
DEFLIST('(
(QUOTE (!'))
(BACKQUOTE (!`))
(UNQUOTE (!,))
(UNQUOTEL (!, !@))
(UNQUOTED (!, !.))),
'READMACROTOKEN);
FOR EACH U IN '(QUOTE BACKQUOTE UNQUOTE) DO PUT(U,'READMACROSIZE,1);
FOR EACH U IN '(UNQUOTEL UNQUOTED) DO PUT(U,'READMACROSIZE,2);
% 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 << PRINC C; GO TO FBLANK >>
ELSE IF BLANKP C THEN IF NOT ATOM BLANKSTOSKIP THEN <<
PRINC '! ;
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 <<
PRINC 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;
PRINC 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;
PRINC '! ;
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;
PRINC '! ;
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,'!]);