Artifact 8c533d6911ff553d46bbb13f1f1b79a77cdc8be3a008522019398f0d70c809c0:

• File r30/rprint.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: 15009) [annotate] [blame] [check-ins using] [more...]

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;