Artifact 18ef06a09c5b1919a6ee6fcab1287ab7849b88307f4e9759eb51b426a74d13f3:
- File
psl-1983/3-1/util/pretty.red
— part of check-in
[eb17ceb7f6]
at
2020-04-21 19:40:01
on branch master
— Add Reduce 3.0 to the historical section of the archive, and some more
files relating to version sof PSL from the early 1980s. Thanks are due to
Paul McJones and Nelson Beebe for these, as well as to all the original
authors.git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 12668) [annotate] [blame] [check-ins using] [more...]
- File
psl-1983/util/pretty.red
— part of check-in
[eb17ceb7f6]
at
2020-04-21 19:40:01
on branch master
— Add Reduce 3.0 to the historical section of the archive, and some more
files relating to version sof PSL from the early 1980s. Thanks are due to
Paul McJones and Nelson Beebe for these, as well as to all the original
authors.git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 12668) [annotate] [blame] [check-ins using]
% <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,'!]);