COMMENT MODULE RPRINT;
COMMENT THE STANDARD LISP TO REDUCE PRETTY PRINTER;
FLUID '(PRETOP PRETOPRINF);
PRETOP := 'OP; PRETOPRINF := 'OPRINF;
FLUID '(COMBUFF);
FLUID '(CURMARK BUFFP RMAR !*N);
SYMBOLIC PROCEDURE RPRINT U;
BEGIN INTEGER !*N; SCALAR BUFF,BUFFP,CURMARK,RMAR,X;
CURMARK := 0;
BUFF := BUFFP := LIST LIST(0,0);
RMAR := LINELENGTH NIL;
X := GET('!*SEMICOL!*,PRETOP);
!*N := 0;
MPRINO1(U,LIST(CAAR X,CADAR X));
PRIN2OX ";";
OMARKO CURMARK;
PRINOS BUFF
END;
SYMBOLIC PROCEDURE RPRIN1 U;
BEGIN SCALAR BUFF,BUFFP,CURMARK,X;
CURMARK := 0;
BUFF := BUFFP := LIST LIST(0,0);
X := GET('!*SEMICOL!*,PRETOP);
MPRINO1(U,LIST(CAAR X,CADAR X));
OMARKO CURMARK;
PRINOS BUFF
END;
SYMBOLIC PROCEDURE MPRINO U; MPRINO1(U,LIST(0,0));
SYMBOLIC PROCEDURE MPRINO1(U,V);
BEGIN SCALAR X;
IF X := ATSOC(U,COMBUFF)
THEN <<FOR EACH Y IN CDR X DO COMPROX Y;
COMBUFF := DELETE(X,COMBUFF)>>;
IF NUMBERP U AND U<0 AND (X := GET('DIFFERENCE,PRETOP))
THEN RETURN BEGIN SCALAR P;
X := CAR X;
P := (NOT CAR X>CADR V) OR (NOT CADR X>CAR V);
IF P THEN PRIN2OX "(";
PRINOX U;
IF P THEN PRINOX ")"
END
ELSE IF ATOM U THEN RETURN PRINOX U
ELSE IF NOT ATOM CAR U
THEN <<CURMARK := CURMARK+1;
PRIN2OX "("; MPRINO CAR U; PRIN2OX ")";
OMARK LIST(CURMARK,3); CURMARK := CURMARK-1>>
ELSE IF X := GET(CAR U,PRETOPRINF)
THEN RETURN BEGIN SCALAR P;
P := CAR V>0 AND NOT CAR U MEMQ '(BLOCK PROG QUOTE STRING);
IF P THEN PRIN2OX "(";
APPLY(X,LIST CDR U);
IF P THEN PRIN2OX ")"
END
ELSE IF X := GET(CAR U,PRETOP)
THEN RETURN IF CAR X THEN INPRINOX(U,CAR X,V)
ELSE IF CDDR U THEN REDERR "Syntax error"
ELSE IF NULL CADR X THEN INPRINOX(U,LIST(100,1),V)
ELSE INPRINOX(U,LIST(100,CADR X),V)
ELSE PRINOX CAR U;
IF RLISTATP CAR U THEN RETURN RLPRI(CDR U,V);
U := CDR U;
IF NULL U THEN PRIN2OX "()"
ELSE MPRARGS(U,V)
END;
SYMBOLIC PROCEDURE MPRARGS(U,V);
IF NULL CDR U THEN <<PRIN2OX " "; MPRINO1(CAR U,LIST(100,100))>>
ELSE INPRINOX('!*COMMA!* . U,LIST(0,0),V);
SYMBOLIC PROCEDURE INPRINOX(U,X,V);
BEGIN SCALAR P;
P := (NOT CAR X>CADR V) OR (NOT CADR X>CAR V);
IF P THEN PRIN2OX "("; OMARK '(M U);
INPRINO(CAR U,X,CDR U);
IF P THEN PRIN2OX ")"; OMARK '(M D)
END;
SYMBOLIC PROCEDURE INPRINO(OPR,V,L);
BEGIN SCALAR FLG,X;
CURMARK := CURMARK+2;
X := GET(OPR,PRETOP);
IF X AND CAR X
THEN <<MPRINO1(CAR L,LIST(CAR V,0)); L := CDR L; FLG := T>>;
WHILE L DO
<<IF OPR EQ '!*COMMA!* THEN <<PRIN2OX ","; OMARKO CURMARK>>
ELSE IF OPR EQ 'SETQ
THEN <<PRIN2OX " := "; OMARK LIST(CURMARK,1)>>
ELSE IF ATOM CAR L OR NOT OPR EQ GET!*(CAAR L,'ALT)
THEN <<OMARK LIST(CURMARK,1); OPRINO(OPR,FLG); FLG := T>>;
MPRINO1(CAR L,LIST(IF NULL CDR L THEN 0 ELSE CAR V,
IF NULL FLG THEN 0 ELSE CADR V));
L := CDR L>>;
CURMARK := CURMARK-2
END;
SYMBOLIC PROCEDURE OPRINO(OPR,B);
(LAMBDA X; IF NULL X
THEN <<IF B THEN PRIN2OX " "; PRINOX OPR; PRIN2OX " ">>
ELSE PRIN2OX CAR X)
GET(OPR,'PRTCH);
SYMBOLIC PROCEDURE PRIN2OX U;
<<RPLACD(BUFFP,EXPLODE2 U);
WHILE CDR BUFFP DO BUFFP := CDR BUFFP>>;
SYMBOLIC PROCEDURE PRINOX U;
<<RPLACD(BUFFP,EXPLODE U);
WHILE CDR BUFFP DO BUFFP := CDR BUFFP>>;
SYMBOLIC PROCEDURE GET!*(U,V);
IF NUMBERP U THEN NIL ELSE GET(U,V);
SYMBOLIC PROCEDURE OMARK U;
<<RPLACD(BUFFP,LIST U); BUFFP := CDR BUFFP>>;
SYMBOLIC PROCEDURE OMARKO U; OMARK LIST(U,0);
SYMBOLIC PROCEDURE COMPROX U;
BEGIN SCALAR X;
IF CAR BUFFP = '(0 0)
THEN RETURN <<FOR EACH J IN U DO PRIN2OX J;
OMARK '(0 0)>>;
X := CAR BUFFP;
RPLACA(BUFFP,LIST(CURMARK+1,3));
FOR EACH J IN U DO PRIN2OX J;
OMARK X
END;
SYMBOLIC PROCEDURE RLISTATP U;
GET(U,'STAT) MEMBER '(ENDSTAT RLIS);
SYMBOLIC PROCEDURE RLPRI(U,V);
IF NULL U THEN NIL
ELSE BEGIN
PRIN2OX " ";
OMARK '(M U);
INPRINO('!*COMMA!*,LIST(0,0),U);
OMARK '(M D)
END;
SYMBOLIC PROCEDURE CONDOX U;
BEGIN SCALAR X;
OMARK '(M U);
CURMARK := CURMARK+2;
WHILE U DO
<<PRIN2OX "IF "; MPRINO CAAR U; OMARK LIST(CURMARK,1);
PRIN2OX " THEN ";
IF CDR U AND EQCAR(CADAR U,'COND)
AND NOT EQCAR(CAR REVERSE CADAR U,'T)
THEN <<X := T; PRIN2OX "(">>;
MPRINO CADAR U;
IF X THEN PRIN2OX ")";
U := CDR U;
IF U THEN <<OMARKO(CURMARK-1); PRIN2OX " ELSE ">>;
IF U AND NULL CDR U AND CAAR U EQ 'T
THEN <<MPRINO CADAR U; U := NIL>>>>;
CURMARK := CURMARK-2;
OMARK '(M D)
END;
PUT('COND,PRETOPRINF,'CONDOX);
SYMBOLIC PROCEDURE BLOCKOX U;
BEGIN
OMARK '(M U);
CURMARK := CURMARK+2;
PRIN2OX "BEGIN ";
IF CAR U THEN VARPRX CAR U;
U := LABCHK CDR U;
OMARK LIST(CURMARK,IF EQCAR(CAR U,'!*LABEL) THEN 1 ELSE 3);
WHILE U DO
<<MPRINO CAR U;
IF NOT EQCAR(CAR U,'!*LABEL) AND CDR U THEN PRIN2OX "; ";
U := CDR U;
IF U
THEN OMARK LIST(CURMARK,
IF EQCAR(CAR U,'!*LABEL) THEN 1 ELSE 3)>>;
OMARK LIST(CURMARK-1,-1);
PRIN2OX " END";
CURMARK := CURMARK-2;
OMARK '(M D)
END;
SYMBOLIC PROCEDURE RETOX U;
BEGIN
OMARK '(M U);
CURMARK := CURMARK+2;
PRIN2OX "RETURN ";
OMARK '(M U);
MPRINO CAR U;
CURMARK := CURMARK-2;
OMARK '(M D);
OMARK '(M D)
END;
PUT('RETURN,PRETOPRINF,'RETOX);
SYMBOLIC PROCEDURE VARPRX U;
MAPC(CDR U,FUNCTION (LAMBDA J;
<<PRIN2OX CAR J;
PRIN2OX " ";
INPRINO('!*COMMA!*,LIST(0,0),CDR J);
PRIN2OX "; ";
OMARK LIST(CURMARK,6)>>));
COMMENT a version for the old parser;
SYMBOLIC PROCEDURE VARPRX U;
BEGIN SCALAR TYP;
U := REVERSE U;
WHILE U DO
<<IF CDAR U EQ TYP
THEN <<PRIN2OX ","; OMARKO(CURMARK+1); PRINOX CAAR U>>
ELSE <<IF TYP THEN <<PRIN2OX "; "; OMARK '(M D)>>;
PRINOX (TYP := CDAR U);
PRIN2OX " "; OMARK '(M U); PRINOX CAAR U>>;
U := CDR U>>;
PRIN2OX "; ";
OMARK '(M D)
END;
PUT('BLOCK,PRETOPRINF,'BLOCKOX);
SYMBOLIC PROCEDURE PROGOX U;
BLOCKOX(MAPCAR(REVERSE CAR U,FUNCTION (LAMBDA J; J . 'SCALAR))
. CDR U);
SYMBOLIC PROCEDURE LABCHK U;
BEGIN SCALAR X;
FOR EACH Z IN U DO IF ATOM Z
THEN X := LIST('!*LABEL,Z) . X ELSE X := Z . X;
RETURN REVERSIP X
END;
PUT('PROG,PRETOPRINF,'PROGOX);
SYMBOLIC PROCEDURE GOX U;
<<PRIN2OX "GO TO "; PRINOX CAR U>>;
PUT('GO,PRETOPRINF,'GOX);
SYMBOLIC PROCEDURE LABOX U;
<<PRINOX CAR U; PRIN2OX ": ">>;
PUT('!*LABEL,PRETOPRINF,'LABOX);
SYMBOLIC PROCEDURE QUOTOX U;
IF STRINGP U THEN PRINOX U ELSE <<PRIN2OX "'"; PRINSOX CAR U>>;
SYMBOLIC PROCEDURE PRINSOX U;
IF ATOM U THEN PRINOX U
ELSE <<PRIN2OX "(";
OMARK '(M U);
CURMARK := CURMARK+1;
WHILE U DO <<PRINSOX CAR U;
U := CDR U;
IF U THEN <<OMARK LIST(CURMARK,-1);
IF ATOM U
THEN <<PRIN2OX " . "; PRINSOX U; U := NIL>>
ELSE PRIN2OX " ">>>>;
CURMARK := CURMARK-1;
OMARK '(M D);
PRIN2OX ")">>;
PUT('QUOTE,PRETOPRINF,'QUOTOX);
SYMBOLIC PROCEDURE PROGNOX U;
BEGIN
CURMARK := CURMARK+1;
PRIN2OX "<<";
OMARK '(M U);
WHILE U DO <<MPRINO CAR U; U := CDR U;
IF U THEN <<PRIN2OX "; "; OMARKO CURMARK>>>>;
OMARK '(M D);
PRIN2OX ">>";
CURMARK := CURMARK-1
END;
PUT('PROG2,PRETOPRINF,'PROGNOX);
PUT('PROGN,PRETOPRINF,'PROGNOX);
SYMBOLIC PROCEDURE REPEATOX U;
BEGIN
CURMARK := CURMARK+1;
OMARK '(M U);
PRIN2OX "REPEAT ";
MPRINO CAR U;
PRIN2OX " UNTIL ";
OMARK LIST(CURMARK,3);
MPRINO CADR U;
OMARK '(M D);
CURMARK := CURMARK-1
END;
PUT('REPEAT,PRETOPRINF,'REPEATOX);
SYMBOLIC PROCEDURE WHILEOX U;
BEGIN
CURMARK := CURMARK+1;
OMARK '(M U);
PRIN2OX "WHILE ";
MPRINO CAR U;
PRIN2OX " DO ";
OMARK LIST(CURMARK,3);
MPRINO CADR U;
OMARK '(M D);
CURMARK := CURMARK-1
END;
PUT('WHILE,PRETOPRINF,'WHILEOX);
SYMBOLIC PROCEDURE PROCOX U;
BEGIN
OMARK '(M U);
CURMARK := CURMARK+1;
IF CADDDR CDR U THEN <<MPRINO CADDDR CDR U; PRIN2OX " ">>;
PRIN2OX "PROCEDURE ";
PROCOX1(CAR U,CADR U,CADDR U)
END;
SYMBOLIC PROCEDURE PROCOX1(U,V,W);
BEGIN
PRINOX U;
IF V THEN MPRARGS(V,LIST(0,0));
PRIN2OX "; ";
OMARK LIST(CURMARK,3);
MPRINO W;
CURMARK := CURMARK-1;
OMARK '(M D)
END;
PUT('PROC,PRETOPRINF,'PROCOX);
SYMBOLIC PROCEDURE PROCEOX U;
BEGIN
OMARK '(M U);
CURMARK := CURMARK+1;
MPRINO CADR U; PRIN2OX " ";
IF NOT CADDR U EQ 'EXPR THEN <<MPRINO CADDR U; PRIN2OX " ">>;
PRIN2OX "PROCEDURE ";
PROCEOX1(CAR U,CADDDR U,CAR CDDDDR U)
END;
SYMBOLIC PROCEDURE PROCEOX1(U,V,W);
BEGIN
PRINOX U;
IF V
THEN <<IF NOT ATOM CAR V THEN V:= FOR EACH J IN V COLLECT CAR J;
%allows for typing to be included with proc arguments;
MPRARGS(V,LIST(0,0))>>;
PRIN2OX "; ";
OMARK LIST(CURMARK,3);
MPRINO W;
CURMARK := CURMARK -1;
OMARK '(M D)
END;
PUT('PROCEDURE,PRETOPRINF,'PROCEOX);
SYMBOLIC PROCEDURE PROCEOX0(U,V,W,X);
PROCEOX LIST(U,'SYMBOLIC,V,
MAPCAR(W,FUNCTION (LAMBDA J; J . 'SYMBOLIC)),X);
SYMBOLIC PROCEDURE DEOX U;
PROCEOX0(CAR U,'EXPR,CADR U,CADDR U);
PUT('DE,PRETOPRINF,'DEOX);
SYMBOLIC PROCEDURE DFOX U;
PROCEOX0(CAR U,'FEXPR,CADR U,CADDR U);
%PUT('DF,PRETOPRINF,'DFOX); %commented out because of confusion with
%differentiation;
SYMBOLIC PROCEDURE STRINGOX U;
<<PRIN2OX '!"; PRIN2OX CAR U; PRIN2OX '!">>;
PUT('STRING,PRETOPRINF,'STRINGOX);
SYMBOLIC PROCEDURE LAMBDOX U;
BEGIN
OMARK '(M U);
CURMARK := CURMARK+1;
PROCOX1('LAMBDA,CAR U,CADR U)
END;
PUT('LAMBDA,PRETOPRINF,'LAMBDOX);
SYMBOLIC PROCEDURE EACHOX U;
<<PRIN2OX "FOR EACH ";
WHILE CDR U DO <<MPRINO CAR U; PRIN2OX " "; U := CDR U>>;
MPRINO CAR U>>;
PUT('FOREACH,PRETOPRINF,'EACHOX);
SYMBOLIC PROCEDURE FOROX U;
BEGIN
CURMARK := CURMARK+1;
OMARK '(M U);
PRIN2OX "FOR ";
MPRINO CAR U;
PRIN2OX " := ";
MPRINO CAADR U;
IF CADR CADR U NEQ 1
THEN <<PRIN2OX " STEP "; MPRINO CADR CADR U; PRIN2OX " UNTIL ">>
ELSE PRIN2OX ":";
MPRINO CADDR CADR U;
PRIN2OX " ";
MPRINO CADDR U;
PRIN2OX " ";
OMARK LIST(CURMARK,3);
MPRINO CADDDR U;
OMARK '(M D);
CURMARK := CURMARK-1
END;
PUT('FOR,PRETOPRINF,'FOROX);
SYMBOLIC PROCEDURE FORALLOX U;
BEGIN
CURMARK := CURMARK+1;
OMARK '(M U);
PRIN2OX "FOR ALL ";
INPRINO('!*COMMA!*,LIST(0,0),CAR U);
IF CADR U
THEN <<OMARK LIST(CURMARK,3);
PRIN2OX " SUCH THAT ";
MPRINO CADR U>>;
PRIN2OX " ";
OMARK LIST(CURMARK,3);
MPRINO CADDR U;
OMARK '(M D);
CURMARK := CURMARK-1
END;
PUT('FORALL,PRETOPRINF,'FORALLOX);
COMMENT Declarations needed by old parser;
IF NULL GET('!*SEMICOL!*,'OP)
THEN <<PUT('!*SEMICOL!*,'OP,'((-1 0)));
PUT('!*COMMA!*,'OP,'((5 6)))>>;
COMMENT RPRINT MODULE, Part 2;
FLUID '(ORIG CURPOS);
SYMBOLIC PROCEDURE PRINOS U;
BEGIN INTEGER CURPOS;
SCALAR ORIG;
ORIG := LIST POSN();
CURPOS := CAR ORIG;
PRINOY(U,0);
TERPRI0X()
END;
SYMBOLIC PROCEDURE PRINOY(U,N);
BEGIN SCALAR X;
IF CAR(X := SPACELEFT(U,N)) THEN RETURN PRINOM(U,N)
ELSE IF NULL CDR X THEN RETURN IF CAR ORIG<10 THEN PRINOM(U,N)
ELSE <<ORIG := 9 . CDR ORIG;
TERPRI0X();
SPACES2(CURPOS := 9+CADAR U);
PRINOY(U,N)>>
ELSE BEGIN
A: U := PRINOY(U,N+1);
IF NULL CDR U OR CAAR U<=N THEN RETURN;
TERPRI0X();
SPACES2(CURPOS := CAR ORIG+CADAR U);
GO TO A END;
RETURN U
END;
SYMBOLIC PROCEDURE SPACELEFT(U,MARK);
%U is an expanded buffer of characters delimited by non-atom marks
%of the form: '(M ...) or '(INT INT))
%MARK is an integer;
BEGIN INTEGER N; SCALAR FLG,MFLG;
N := RMAR - CURPOS;
U := CDR U; %move over the first mark;
WHILE U AND NOT FLG AND N>=0 DO
<<IF ATOM CAR U THEN N := N-1
ELSE IF CAAR U EQ 'M THEN NIL
ELSE IF MARK>=CAAR U THEN <<FLG := T; U := NIL . U>>
ELSE MFLG := T;
U := CDR U>>;
RETURN ((N>=0) . MFLG)
END;
SYMBOLIC PROCEDURE PRINOM(U,MARK);
BEGIN INTEGER N; SCALAR FLG,X;
N := CURPOS;
U := CDR U;
WHILE U AND NOT FLG DO
<<IF ATOM CAR U THEN <<X := PRIN20X CAR U; N := N+1>>
ELSE IF CAAR U EQ 'M
THEN IF CADAR U EQ 'U THEN ORIG := N . ORIG
ELSE ORIG := CDR ORIG
ELSE IF MARK>=CAAR U
AND NOT(X='!, AND RMAR-N-6>CHARSPACE(U,X,MARK))
THEN <<FLG := T; U := NIL . U>>;
U := CDR U>>;
CURPOS := N;
IF MARK=0 AND CDR U
THEN <<TERPRI0X();
TERPRI0X();
ORIG := LIST 0; CURPOS := 0; PRINOY(U,MARK)>>;
%must be a top level constant;
RETURN U
END;
SYMBOLIC PROCEDURE CHARSPACE(U,CHAR,MARK);
%determines if there is space until the next character CHAR;
BEGIN INTEGER N;
N := 0;
WHILE U DO
<<IF CAR U = CHAR THEN U := LIST NIL
ELSE IF ATOM CAR U THEN N := N+1
ELSE IF CAR U='(M U) THEN <<N := 1000; U := LIST NIL>>
ELSE IF NUMBERP CAAR U AND CAAR U<MARK THEN U := LIST NIL;
U := CDR U>>;
RETURN N
END;
SYMBOLIC PROCEDURE SPACES2 N;
%FOR I := 1:N DO PRIN20X '! ;
WHILE N>0 DO <<PRIN20X '! ; N := N-1>>;
SYMBOLIC PROCEDURE PRIN2ROX U;
BEGIN INTEGER M,N; SCALAR X,Y;
M := RMAR-12;
N := RMAR-1;
WHILE U DO
IF CAR U EQ '!"
THEN <<IF NOT STRINGSPACE(CDR U,N-!*N)
THEN <<TERPRI0X(); !*N := 0>>
ELSE NIL;
PRIN20X '!";
U := CDR U;
WHILE NOT CAR U EQ '!" DO
<<PRIN20X CAR U; U := CDR U; !*N := !*N+1>>;
PRIN20X '!";
U := CDR U;
!*N := !*N+2;
X := Y := NIL>>
ELSE IF ATOM CAR U AND NOT(CAR U EQ '! AND (!*N=0 OR NULL X
OR CDR U AND BREAKP CADR U OR BREAKP X AND NOT Y EQ '!!))
THEN <<Y := X; PRIN20X(X := CAR U); !*N := !*N+1;
U := CDR U;
IF !*N=N OR !*N>M AND NOT BREAKP CAR U AND NOSPACE(U,N-!*N)
THEN <<TERPRI0X(); X := Y := NIL>> ELSE NIL>>
ELSE U := CDR U
END;
SYMBOLIC PROCEDURE NOSPACE(U,N);
IF N<1 THEN T
ELSE IF NULL U THEN NIL
ELSE IF NOT ATOM CAR U THEN NOSPACE(CDR U,N)
ELSE IF NOT CAR U EQ '!! AND (CADR U EQ '! OR BREAKP CADR U)
THEN NIL
ELSE NOSPACE(CDR U,N-1);
SYMBOLIC PROCEDURE BREAKP U;
U MEMBER '(!< !> !; !: != !) !+ !- !, !' !");
SYMBOLIC PROCEDURE STRINGSPACE(U,N);
IF N<1 THEN NIL ELSE IF CAR U EQ '!" THEN T
ELSE STRINGSPACE(CDR U,N-1);
COMMENT Some interfaces needed;
PUT('CONS,'PRTCH,'(! !.! !.));
GLOBAL '(RPRIFN!* RTERFN!*);
COMMENT RPRIFN!* allows output from RPRINT to be handled differently,
RTERFN!* allows end of lines to be handled differently;
SYMBOLIC PROCEDURE PRIN20X U;
IF RPRIFN!* THEN APPLY(RPRIFN!*,LIST U) ELSE PRIN2 U;
SYMBOLIC PROCEDURE TERPRI0X;
IF RTERFN!* THEN APPLY(RTERFN!*,NIL) ELSE TERPRI();
END;