(FILECREATED "16-Aug-84 17:27:08" {ERIS}<LISPCORE>SOURCES>APRINT.;3
 24847  

      changes to:  (FNS \FILEOUTCHARFN)

      previous date: " 7-Apr-84 14:47:11" {ERIS}<LISPCORE>SOURCES>APRINT.;2)


(* Copyright (c) 1982, 1983, 1984 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT APRINTCOMS)

(RPAQQ APRINTCOMS
 [(DECLARE: FIRST (P (RESETSAVE PRETTYHEADER NIL)))
	(FNS PRIN1 PRIN2 PRIN3 PRIN4 PRINT PRINTLEVEL RADIX SPACES TERPRI FRESHLINE DEFPRINT 
	     LINELENGTH \CKPOSBOUT \CKPOSSOUT \CONVERTNUMBER \LITPRIN \OUTCHAR \SOUT \PRINDATUM 
	     \PRINOTHER \PRINSTACKP \PRINSTRING)
	(FNS \FILEOUTCHARFN \TTYOUTCHARFN)
	(FNS \MAPCHARS \MAPCHARS1 \PRODUCESTRING \PRODUCENUM \PRODUCEADDR \MAPCHARSLIT)
	(FNS \APRINTINIT)
	(INITVARS (\CARPRINTLEVEL 1000)
		  (\PRINTCRFLAG NIL)
		  (\CDRPRINTLEVEL -1)
		  (PLVLFILEFLG NIL)
		  (\LINELENGTH 82)
		  (\FLOATFORMAT T)
		  (PRXFLG NIL)
		  (\PRINTRADIX 10)
		  (\SIGNFLAG T)
		  (\DEFPRINTFNS NIL))
	[COMS (FNS FLTFMT \CHECKFLTFMT NUMFORMATCODE PRINTNUM)
	      (MACROS NUMFORMATCODE)
	      (INITVARS (NILNUMPRINTFLG))
	      (P (MOVD? (QUOTE PRINTNUM)
			(QUOTE FPRINTNUM]
	(DECLARE: DONTCOPY (MACROS .FILELINELENGTH. .SPACECHECK. \PRODUCECHAR))
	(LOCALVARS . T)
	(SPECVARS \THISFILELINELENGTH)
	(GLOBALVARS \CARPRINTLEVEL \TCARPRINTLEVEL \PRINTCRFLAG \CDRPRINTLEVEL \TCDRPRINTLEVEL 
		    \LINELENGTH \FLOATFORMAT \PRINTRADIX \SIGNFLAG PRXFLG \DEFPRINTFNS)
	(DECLARE: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY (P (\APRINTINIT])
(DECLARE: FIRST 
(RESETSAVE PRETTYHEADER NIL)
)
(DEFINEQ

(PRIN1

  [LAMBDA (X FILE)                                           (* rmk: "21-OCT-83 12:31")

    (PROG ((\OFD (\GETSTREAM FILE (QUOTE OUTPUT)))
	   \THISFILELINELENGTH)
          (DECLARE
 (SPECVARS \THISFILELINELENGTH))
          (SETQ \THISFILELINELENGTH (.FILELINELENGTH. \OFD))
          (SETQ \TCARPRINTLEVEL \CARPRINTLEVEL)
          (SETQ \TCDRPRINTLEVEL \CDRPRINTLEVEL)
          (\PRINDATUM
 X \OFD NIL (COND
			((OR (\OUTTERMP \OFD)
			     PLVLFILEFLG)
			  0)))
          (RETURN X])

(PRIN2

  [LAMBDA (X FILE RDTBL)                                     (* rmk: "21-OCT-83 12:31")

    (PROG ((\OFD (\GETSTREAM FILE (QUOTE OUTPUT)))
	   \THISFILELINELENGTH)
          (DECLARE
 (SPECVARS \THISFILELINELENGTH))
          (SETQ \THISFILELINELENGTH (.FILELINELENGTH. \OFD))
          (SETQ \TCARPRINTLEVEL \CARPRINTLEVEL)
          (SETQ \TCDRPRINTLEVEL \CDRPRINTLEVEL)
          (\PRINDATUM
 X \OFD (fetch
 READSA of
 (\GTREADTABLE RDTBL))
		      (COND
			((OR (\OUTTERMP \OFD)
			     PLVLFILEFLG)
			  0)))
          (RETURN X])

(PRIN3

  [LAMBDA (X FILE)                                           (* rmk: "21-OCT-83 12:31")

    (PROG [\THISFILELINELENGTH (\OFD (\GETSTREAM FILE (QUOTE OUTPUT]
          (DECLARE
 (SPECVARS \THISFILELINELENGTH))
          (SETQ \TCARPRINTLEVEL \CARPRINTLEVEL)
          (SETQ \TCDRPRINTLEVEL \CDRPRINTLEVEL)
          [replace
 CHARPOSITION of
 \OFD with
 (PROG1 (fetch
 CHARPOSITION of
 \OFD)
						    (\PRINDATUM
 X \OFD NIL (COND
								  ((OR (\OUTTERMP \OFD)
								       PLVLFILEFLG)
								    0]
          (RETURN X])

(PRIN4

  [LAMBDA (X FILE RDTBL)                                     (* rmk: "21-OCT-83 12:31")

    (PROG [\THISFILELINELENGTH (\OFD (\GETSTREAM FILE (QUOTE OUTPUT]
          (DECLARE
 (SPECVARS \THISFILELINELENGTH))
          (SETQ \TCARPRINTLEVEL \CARPRINTLEVEL)
          (SETQ \TCDRPRINTLEVEL \CDRPRINTLEVEL)
          [replace
 CHARPOSITION of
 \OFD with
 (PROG1 (fetch
 CHARPOSITION of
 \OFD)
						    (\PRINDATUM
 X \OFD (fetch
 READSA
									  of
 (\GTREADTABLE RDTBL))
								(COND
								  ((OR (\OUTTERMP \OFD)
								       PLVLFILEFLG)
								    0]
          (RETURN X])

(PRINT

  [LAMBDA (X FILE RDTBL)                                     (* rmk: "21-OCT-83 12:31")

    (PROG [\THISFILELINELENGTH (\OFD (\GETSTREAM FILE (QUOTE OUTPUT]
          (DECLARE
 (SPECVARS \THISFILELINELENGTH))
          (SETQ \THISFILELINELENGTH (.FILELINELENGTH. \OFD))
          (SETQ \TCARPRINTLEVEL \CARPRINTLEVEL)
          (SETQ \TCDRPRINTLEVEL \CDRPRINTLEVEL)
          (\PRINDATUM
 X \OFD (fetch
 READSA of
 (\GTREADTABLE RDTBL))
		      (COND
			((OR (\OUTTERMP \OFD)
			     PLVLFILEFLG)
			  0)))
          (\OUTCHAR
 \OFD (CHARCODE EOL))
          (RETURN X])

(PRINTLEVEL

  [LAMBDA (CARVAL CDRVAL)                                   (* rmk: "28-APR-80 12:07")

    [COND
      ((LISTP CARVAL)
	(SETQ CDRVAL (CDR CARVAL))
	(SETQ CARVAL (CAR CARVAL]
    (PROG ((OLD
 (CONS (COND
			(\PRINTCRFLAG (IDIFFERENCE 0 \CARPRINTLEVEL))
			(T \CARPRINTLEVEL))
		      \CDRPRINTLEVEL))
	   LEV)
          (COND
	    (CARVAL [COND
		      ([SETQ \PRINTCRFLAG (IGREATERP 0 (SETQ LEV (FIX CARVAL]
			(SETQ LEV (IDIFFERENCE 0 LEV]
		    (SETQ \CARPRINTLEVEL LEV)))
          [COND
	    (CDRVAL (SETQ \CDRPRINTLEVEL (FIX CDRVAL]
          (RETURN OLD])

(RADIX

  [LAMBDA (N)                                               (* N.Greenfeld "11-Jun-81 10:11")

    (PROG ([OLD
 (COND
		  (\SIGNFLAG \PRINTRADIX)
		  (T (IDIFFERENCE 0 \PRINTRADIX]
	   R S)
          (COND
	    (N [COND
		 ((SETQ S (IGREATERP (SETQ R (FIX N))
				     0)))
		 (T (SETQ R (IDIFFERENCE 0 R]
	       (COND
		 ((OR (IGREATERP 2 R)
		      (IGREATERP R 16))
		   (\ILLEGAL.ARG R)))
	       (SETQ \PRINTRADIX R)
	       (SETQ \SIGNFLAG S)))
          (RETURN OLD])

(SPACES

  [LAMBDA (N FILE)                                           (* rmk: "21-OCT-83 12:32")

    [PROG ((STREAM (\GETSTREAM FILE (QUOTE OUTPUT)))
	   \THISFILELINELENGTH)
          (SETQ \THISFILELINELENGTH (.FILELINELENGTH. STREAM))
          (.SPACECHECK. STREAM N)
          (FRPTQ N (\OUTCHAR
 STREAM (CHARCODE SPACE]
    NIL])

(TERPRI

  [LAMBDA (FILE)                                             (* rmk: "21-OCT-83 12:31")

    (\OUTCHAR
 (\GETSTREAM FILE (QUOTE OUTPUT))
	      (CHARCODE EOL))
    NIL])

(FRESHLINE

  [LAMBDA (STREAM)                                           (* rmk: "22-AUG-83 13:48")

                                                             (* Adjusts the STREAM to be at a new line -- does 

							     equivalent of TERPRI unless it is already 

							     "sitting at the beginning of a line")

    (if
 [NEQ 0 (fetch
 CHARPOSITION of
 (if
 (AND (type?
 STREAM STREAM)
					       (WRITEABLE STREAM))
					  then
 STREAM
					else
 (SETQ STREAM (GETSTREAM STREAM (QUOTE OUTPUT]
	then
 (\OUTCHAR
 STREAM (CHARCODE EOL))
	     T])

(DEFPRINT

  [LAMBDA (TYPE FN)                                         (* rmk: "28-APR-80 12:04")

    (AND (FIXP TYPE)
	 (SETQ TYPE (\TYPENAMEFROMNUMBER TYPE)))            (* The FIXP case should never occur)

    (PROG ((F (FASSOC TYPE \DEFPRINTFNS)))
          [COND
	    (F (SETQ \DEFPRINTFNS (DREMOVE F \DEFPRINTFNS]
          [COND
	    (FN (SETQ \DEFPRINTFNS (CONS (CONS TYPE FN)
					 \DEFPRINTFNS]
          (RETURN (CDR F])

(LINELENGTH

  [LAMBDA (N FILE)                                           (* rmk: "21-OCT-83 12:31")

                                                             (* Sets to N the linelength of FILE 

							     (NIL defaults to primary output file))

    (PROG [(STREAM (\GETSTREAM FILE (QUOTE OUTPUT]
          (RETURN (PROG1 (fetch
 (STREAM LINELENGTH) of
 STREAM)
			 (AND N (COND
				((IGREATERP 1 N)
				  (\ILLEGAL.ARG N))
				(T (replace
 (STREAM LINELENGTH) of
 STREAM with
 (FIX N])

(\CKPOSBOUT

  [LAMBDA (STREAM X)                                         (* rmk: "21-OCT-83 12:32")

    (.SPACECHECK. STREAM 1)
    (\OUTCHAR
 STREAM X])

(\CKPOSSOUT

  [LAMBDA (STREAM X)                                         (* rmk: "21-OCT-83 12:32")

    (.SPACECHECK. STREAM (\NSTRINGCHARS X))
    (for
 I instring
 X do
 (\OUTCHAR
 STREAM I])

(\CONVERTNUMBER

  [LAMBDA (N R SFLAG QFLAG NS NSB)                          (* rmk: "14-APR-82 00:06")

    (PROG ((X N)
	   Y SIGN (POS (SUB1 (NCHARS NS)))
	   END DIGIT)
          [COND
	    [(IGREATERP 0 N)
	      (COND
		(SFLAG (SETQ Y (IQUOTIENT X R))
		       (SETQ SIGN T))
		(T                                          (* Compute X as remainder of N and R, Y as quotient)

		   (COND
		     ((EQ R 8)
		       (SETQ X (LOGAND N 7))
		       (SETQ Y (LRSH N 3)))
		     (T (PROG ((Q (IQUOTIENT 1073741824 R))
			       P
			       (\OVERFLOW 0))
			      (DECLARE
 (SPECVARS \OVERFLOW))
			      (SETQ Y 0)
			      (SETQ P (ITIMES Q R))
			  RED (SETQ X (IDIFFERENCE X P))
			      (SETQ Y (IPLUS Y Q))
			      (COND
				((ILESSP X 0)
				  (GO RED)))
			      (SETQ Y (IPLUS Y (IQUOTIENT X R]
	    (T (SETQ Y (IQUOTIENT X R]
          (COND
	    ((AND (EQ R 8)
		  QFLAG
		  (OR (IGREATERP X 7)
		      (ILESSP X -7)))
	      (RPLCHARCODE NS (SETQ END (ADD1 POS))
			   (CHARCODE Q)))
	    (T (SETQ END POS)))
          (SETQ DIGIT (COND
	      ((IGREATERP 0 (SETQ X (IREMAINDER X R)))
		(IDIFFERENCE 0 X))
	      (T X)))
          [RPLCHARCODE NS POS (IPLUS DIGIT (COND
				       ((ILESSP DIGIT 10)
					 (CHARCODE 0))
				       (T (IDIFFERENCE (CHARCODE A)
						       10]
          (AND (IGREATERP 0 Y)
	       (SETQ Y (IDIFFERENCE 0 Y)))                  (* The first character is done outside the loop so that 

							    there will not be a problem negating the least negative 

							    number)

      LP  [COND
	    ((EQ (SETQ X Y)
		 0)
	      [COND
		(SIGN (RPLCHARCODE NS (SETQ POS (SUB1 POS))
				   (CHARCODE -]
	      (RETURN (SUBSTRING NS POS END NSB]
          (SETQ Y (IQUOTIENT X R))
          (SETQ DIGIT (IREMAINDER X R))
          [RPLCHARCODE NS (SETQ POS (SUB1 POS))
		       (COND
			 ((ILESSP DIGIT 10)
			   (IPLUS DIGIT (CHARCODE 0)))
			 (T (IPLUS (IDIFFERENCE DIGIT 10)
				   (CHARCODE A]
          (GO LP])

(\LITPRIN

  [LAMBDA (X SA STREAM)                                      (* rmk: "21-OCT-83 12:32")

    (DECLARE
 (USEDFREE \THISFILELINELENGTH))
    (COND
      ((EQ X (QUOTE %.))
	(COND
	  (SA (.SPACECHECK. STREAM 2)
	      (\OUTCHAR
 STREAM (CHARCODE %%)))
	  (T (.SPACECHECK. STREAM 1)))
	(\OUTCHAR
 STREAM (CHARCODE %.)))
      (SA [.SPACECHECK. STREAM (IPLUS (\NATOMCHARS X)
				      (for
 C inatom
 X count
 (fetch
 (READCODE ESCQUOTE)
							       of
 (\SYNCODE SA C]
	  (for
 C inatom
 X
	     do
 (AND (fetch
 (READCODE ESCQUOTE) of
 (\SYNCODE SA C))
		     (\OUTCHAR
 STREAM (CHARCODE %%)))
		(\OUTCHAR
 STREAM C)))
      (T (.SPACECHECK. STREAM (\NATOMCHARS X))
	 (for
 C inatom
 X do
 (\OUTCHAR
 STREAM C])

(\OUTCHAR

  [LAMBDA (STREAM CHARCODE)                                 (* rmk: " 7-APR-82 00:25")

    (STREAMOP (QUOTE OUTCHARFN)
	      STREAM STREAM CHARCODE])

(\SOUT

  [LAMBDA (X STREAM)                                         (* rmk: "21-OCT-83 12:32")

    (for
 I instring
 X do
 (\OUTCHAR
 STREAM I])

(\PRINDATUM

  [LAMBDA (X STREAM SA CPL)                                  (* rmk: "21-OCT-83 12:32")

                                                             (* NOTE: IF YOU CHANGE \PRINDATUM, YOU MUST CHANGE 

							     \MAPCHARS1 AS WELL TO CORRESPOND!)

                                                             (* CPL is the current printing level, NIL if print-level

							     should be ignored)

    (SELECTC (NTYPX X)
	     (\LITATOM (\LITPRIN
 X SA STREAM))
	     [\LISTP (PROG (CDRCNT)                          (* We can pre-compute whether \TCDRPRINTLEVEL is 

							     negative, because its sign can't be dynamically changed 

							     by ^P. Similarly, \PRINTCRFLAG cannot be dynamically 

							     changed.)

		           (COND
			     ((AND CPL (IGREATERP (SETQ CPL (ADD1 CPL))
						  \TCARPRINTLEVEL))
			       (\CKPOSBOUT
 STREAM (CHARCODE &))
			       (RETURN)))
		           (\CKPOSBOUT
 STREAM (CHARCODE %())
		           (AND CPL (IGREATERP \TCDRPRINTLEVEL -1)
				(SETQ CDRCNT CPL))
		       LP  (\PRINDATUM
 (CAR X)
				       STREAM SA CPL)
		           (COND
			     [(NLISTP (CDR X))
			       (COND
				 ((SETQ X (CDR X))
				   (\CKPOSSOUT
 STREAM (QUOTE " . "))
				   (\PRINDATUM
 X STREAM SA CPL]
			     ([AND CPL (OR (IGREATERP CPL \TCARPRINTLEVEL)
					   (AND CDRCNT (NOT (IGREATERP \TCDRPRINTLEVEL CDRCNT]
			       (\CKPOSSOUT
 STREAM (QUOTE " --")))
			     (T [COND
				  ((AND \PRINTCRFLAG CPL (LISTP (CAR X))
					\THISFILELINELENGTH
					(LISTP (CADR X)))
				    (\OUTCHAR
 STREAM (CHARCODE EOL)))
				  (T (\CKPOSBOUT
 STREAM (CHARCODE SPACE]
				(SETQ X (CDR X))
				(AND CDRCNT (ADD1VAR CDRCNT))
				(GO LP)))
		           (\CKPOSBOUT
 STREAM (CHARCODE %)]
	     [(LIST \SMALLP \FIXP)
	       (GLOBALRESOURCE (\NUMSTR \NUMSTR1)
			       (\CKPOSSOUT
 STREAM (\CONVERTNUMBER
 X \PRINTRADIX \SIGNFLAG SA \NUMSTR 
								  \NUMSTR1]
	     [\FLOATP (GLOBALRESOURCE (\NUMSTR \NUMSTR1)
				      (\CKPOSSOUT
 STREAM (\CONVERT.FLOATING.NUMBER X \NUMSTR \NUMSTR1]
	     (\STRINGP (\PRINSTRING
 X STREAM SA))
	     (\STACKP (\PRINSTACKP
 X STREAM))
	     (PROG [(FN (CDR (FASSOC (TYPENAME X)
				     \DEFPRINTFNS]
	           (RETURN (COND
			     ([OR (NULL FN)
				  (NULL (SETQ FN (APPLY* FN X (fetch
 FULLNAME of
 STREAM]
			       (\PRINOTHER
 X STREAM SA))
			     ((LISTP FN)
			       (AND (CAR FN)
				    (\PRINDATUM
 (CAR FN)
						STREAM NIL CPL))
			       (AND (CDR FN)
				    (\PRINDATUM
 (CDR FN)
						STREAM SA CPL])

(\PRINOTHER

  [LAMBDA (X OFD\PRINOTHER SA)
    (DECLARE
 (SPECVARS OFD\PRINOTHER))                      (* N.Greenfeld "17-Jun-81 15:06")

    (.SPACECHECK. OFD\PRINOTHER (NCHARS X))
    (\MAPCHARS
 (FUNCTION [LAMBDA (CH)
		   (\OUTCHAR
 OFD\PRINOTHER CH])
	       X])

(\PRINSTACKP

  [LAMBDA (X OFD\PRINSTACKP)
    (DECLARE
 (SPECVARS OFD\PRINSTACKP))                     (* rmk: " 1-APR-82 17:24")

    [.SPACECHECK. OFD\PRINSTACKP (IPLUS 2 7 (COND
					  ((RELSTKP X)
					    2)
					  ((LITATOM (STKNAME X))
					    (\NATOMCHARS (STKNAME X)))
					  (T 6]
    (\MAPCHARS
 (FUNCTION [LAMBDA (X)
		   (\OUTCHAR
 OFD\PRINSTACKP X])
	       X])

(\PRINSTRING

  [LAMBDA (X STREAM SA)                                      (* rmk: "21-OCT-83 12:32")

                                                             (* We key on specific characters, not syntax code, cause

							     that's the way the 10 seems to do it.)

    (COND
      (SA [.SPACECHECK. STREAM (IPLUS 2 (\NSTRINGCHARS X)
				      (for
 C instring
 X count
 (SELCHARQ C
									((%" %%))
									NIL]
	  (\OUTCHAR
 STREAM (CHARCODE %"))
	  (for
 C instring
 X
	     do
 (SELCHARQ C
			  ((%" %% LF)
			    (\OUTCHAR
 STREAM (CHARCODE %%)))
			  NIL)                               (* VM says only %" is escaped no matter what 

							     stringdelim's are.)

		(\OUTCHAR
 STREAM C))
	  (\OUTCHAR
 STREAM (CHARCODE %")))
      (T (.SPACECHECK. STREAM (\NSTRINGCHARS X))
	 (\SOUT
 X STREAM])
)
(DEFINEQ

(\FILEOUTCHARFN

  [LAMBDA (STREAM CHARCODE)                                  (* bvm: "16-Aug-84 17:20")

                                                             (* OUTCHARFN for standard files)

    (COND
      ((EQ CHARCODE (CHARCODE EOL))
	(\BOUT STREAM (SELECTC (fetch
 EOLCONVENTION of
 STREAM)
			       (CR.EOLC (CHARCODE CR))
			       (LF.EOLC (CHARCODE LF))
			       (CRLF.EOLC (\BOUT STREAM (CHARCODE CR))
					  (CHARCODE LF))
			       (SHOULDNT)))
	(replace
 CHARPOSITION of
 STREAM with
 0))
      (T (\BOUT STREAM CHARCODE)
	 (replace
 CHARPOSITION of
 STREAM with
 (PROGN         (* Ugh. Don't overflow)

						     (\LOLOC (\ADDBASE (fetch
 CHARPOSITION
									  of
 STREAM)
								       1])

(\TTYOUTCHARFN

  [LAMBDA (STREAM CH)                                        (* rmk: "14-Mar-84 23:23")

                                                             (* OUTCHARFN for TTY when dribble is on)

    (\OUTCHAR
 \DRIBBLE.OFD CH)
    (SPREADAPPLY*(LISTGET (fetch
 OTHERPROPS of
 STREAM)
			  (QUOTE \OUTCHAR))
      STREAM CH])
)
(DEFINEQ

(\MAPCHARS

  [LAMBDA (FN X FLG RDTBL)                                  (* lmm " 9-MAY-80 22:45")

    (\MAPCHARS1
 X (AND FLG (fetch
 READSA of
 (\GTREADTABLE RDTBL)))
		FN])

(\MAPCHARS1

  [LAMBDA (X SA FN)                (* lmm "24-JUL-83 14:23")

    (DECLARE
 (SPECVARS FN))
    (SELECTC (NTYPX X)
	     [\LITATOM (COND
			 [SA (COND
			       ((EQ X (QUOTE %.))
				 (\PRODUCESTRING
 "%%."))
			       (T (\MAPCHARSLIT
 X SA FN]
			 (T (\MAPCHARSLIT
 X NIL FN]
	     (\LISTP (\PRODUCECHAR (CHARCODE %())
		     [PROG NIL
		       LP  (\MAPCHARS1
 (CAR X)
				       SA FN)
		           (COND
			     [(NLISTP (CDR X))
			       (COND
				 ((SETQ X (CDR X))
				   (\PRODUCESTRING
 " . ")
				   (\MAPCHARS1
 X SA FN]
			     (T (\PRODUCECHAR (CHARCODE SPACE))
				(SETQ X (CDR X))
				(GO LP]
		     (\PRODUCECHAR (CHARCODE %))))
	     ((LIST \SMALLP \FIXP)
	       (\PRODUCENUM
 X (COND
			      (PRXFLG \PRINTRADIX)
			      (T 10))
			    (OR (NULL PRXFLG)
				\SIGNFLAG)
			    SA))
	     [\FLOATP (GLOBALRESOURCE (\NUMSTR \NUMSTR1)
				      (\PRODUCESTRING
 (\CONVERT.FLOATING.NUMBER X \NUMSTR \NUMSTR1
										(COND
										  (PRXFLG 
										     \FLOATFORMAT)
										  (T T]
	     [\STRINGP (COND
			 (SA (\PRODUCECHAR (CHARCODE %"))
			     (for
 C instring
 X
				do
 (SELCHARQ C
					     ((%" %% LF)
					       (\PRODUCECHAR (CHARCODE %%)))
					     NIL)
				   (\PRODUCECHAR C))
			     (\PRODUCECHAR (CHARCODE %")))
			 (T (\PRODUCESTRING
 X]
	     (\STACKP (\PRODUCEADDR
 X)
		      (\PRODUCECHAR (CHARCODE /))
		      (\MAPCHARSLIT
 (COND
				      ((RELSTKP X)
					(QUOTE #0))
				      ((LITATOM (SETQ X (STKNAME X)))
					X)
				      (T (QUOTE *form*)))
				    SA FN))
	     (PROG [(DEFPFN (CDR (FASSOC (TYPENAME X)
					 \DEFPRINTFNS]
	           (RETURN (COND
			     ([OR (NULL DEFPFN)
				  (NULL (SETQ DEFPFN (APPLY* DEFPFN X]
			       (\PRODUCECHAR (CHARCODE {))
			       (AND (TYPENAME X)
				    (\MAPCHARSLIT
 (TYPENAME X)
						  SA FN))
			       (\PRODUCECHAR (CHARCODE }))
			       (\PRODUCEADDR
 X))
			     ((LISTP DEFPFN)
			       (AND (CAR DEFPFN)
				    (\MAPCHARS1
 (CAR DEFPFN)
						NIL FN))
			       (AND (CDR DEFPFN)
				    (\MAPCHARS1
 (CDR DEFPFN)
						SA FN])

(\PRODUCESTRING

  [LAMBDA (X)                                               (* N.Greenfeld "11-Jun-81 09:29")

    (for
 C instring
 X do
 (\PRODUCECHAR C])

(\PRODUCENUM

  [LAMBDA (N R SFLAG QFLAG)                                 (* rmk: "23-DEC-80 21:16")

    (GLOBALRESOURCE (\NUMSTR \NUMSTR1)
        (\PRODUCESTRING
 (\CONVERTNUMBER
 N R SFLAG QFLAG \NUMSTR \NUMSTR1)))])

(\PRODUCEADDR

  [LAMBDA (ADDR)                   (* lmm " 5-MAR-83 00:23")

    (\PRODUCECHAR (CHARCODE #))
    (SELECTQ (SYSTEMTYPE)
	     (D (\PRODUCENUM
 (\HILOC ADDR)
			     8)
		(\PRODUCECHAR (CHARCODE ,))
		(\PRODUCENUM
 (\LOLOC ADDR)
			     8))
	     (JERICHO (\PRODUCENUM
 (LOGAND \ADDRMASK (LOC ADDR))
				   8 NIL))
	     (VAX (\PRODUCENUM
 (LOC ADDR)
			       16 T))
	     ((TENEX TOPS-20)
	       (\PRODUCENUM
 (LOC ADDR)
			    8 T))
	     (SYSTEMTYPEPUNT (QUOTE (\PRODUCEADDR
 ADDR])

(\MAPCHARSLIT

  [LAMBDA (X SA FN)                                         (* N.Greenfeld "11-Jun-81 09:30")

    (for
 C inatom
 X do
 (AND SA (fetch
 (READCODE ESCQUOTE) of
 (\SYNCODE SA C))
			    (\PRODUCECHAR (CHARCODE %%)))
		       (\PRODUCECHAR C])
)
(DEFINEQ

(\APRINTINIT

  [LAMBDA NIL                                               (* N.Greenfeld " 9-Oct-81 15:31")

                                                            (* This is here for the JERICHO bootstrap process.

							    Note that MKSTRING and NCHARS are here rather than in 

							    JATOM because they use \MAPCHARS.)

    (SELECTQ (SYSTEMTYPE)
	     (JERICHO [MAPC (QUOTE (MKSTRING NCHARS))
			    (FUNCTION (LAMBDA (X)
				(MOVD (PACK* (QUOTE \\)
					     X)
				      X]
		      (SETQ \TERM.OFD (COPYIOD \TERM.OFD .TTYOUTIOD))
		      (SETQ \TERM.OFD.SAV \TERM.OFD))
	     NIL])
)

(RPAQ? \CARPRINTLEVEL
 1000)

(RPAQ? \PRINTCRFLAG
 NIL)

(RPAQ? \CDRPRINTLEVEL
 -1)

(RPAQ? PLVLFILEFLG
 NIL)

(RPAQ? \LINELENGTH
 82)

(RPAQ? \FLOATFORMAT
 T)

(RPAQ? PRXFLG
 NIL)

(RPAQ? \PRINTRADIX
 10)

(RPAQ? \SIGNFLAG
 T)

(RPAQ? \DEFPRINTFNS
 NIL)
(DEFINEQ

(FLTFMT

  [LAMBDA (FORMAT)                                          (* bvm: "30-JAN-81 23:20")

                                                            (* numeric arg, as on 10, not allowed)

    (PROG1 \FLOATFORMAT (AND FORMAT (\CHECKFLTFMT
 FORMAT)
			     (SETQ \FLOATFORMAT FORMAT])

(\CHECKFLTFMT

  [LAMBDA (FORMAT)                                          (* bvm: "29-JAN-81 15:41")


          (* * Generates error if FORMAT is not legal FLOAT format: (FLOAT WIDTH DECPART EXPPART PAD SIGDIGITS))



    (COND
      ([OR (EQ FORMAT T)
	   (AND (EQ (CAR FORMAT)
		    (QUOTE FLOAT))
		(EVERY (CDR FORMAT)
		       (FUNCTION (LAMBDA (X)
			   (OR (NULL X)
			       (FIXP X]
	FORMAT)
      (T (LISPERROR "ILLEGAL ARG" FORMAT])

(NUMFORMATCODE

  [LAMBDA (FORMAT SMASHCODE)                                (* rmk: "21-MAY-82 17:35")

                                                            (* A dummy in case a user has been calling it.

							    10 does validity checking as well as format translation,

							    but we won't bother)

    FORMAT])

(PRINTNUM

  [LAMBDA (FORMAT NUMBER FILE)                              (* DECLARATIONS: (RECORD FIXFMT 

							    (WIDTH RADIX PAD0 LEFTFLUSH)) 

							    (RECORD FLOATFMT (WIDTH DECPART EXPPART PAD0 SIGDIGITS))
)
                                                           (* rmk: "17-MAY-82 10:07")

    (DECLARE
 (GLOBALVARS NILNUMPRINTFLG))
    (GLOBALRESOURCE (\NUMSTR \NUMSTR1)
        (PROG (STR WIDTH PAD TEMP RAD (FLOATFLAG (SELECTQ (CAR (LISTP FORMAT))
							  (FLOAT T)
							  (FIX NIL)
							  (LISPERROR "ILLEGAL ARG" FORMAT)))
		   (FMT (CDR FORMAT)))
	      (SETQ WIDTH (fetch
 WIDTH of
 FMT))
	      [SETQ STR (COND
		  ((AND (NULL NUMBER)
			NILNUMPRINTFLG))
		  (FLOATFLAG (\CONVERT.FLOATING.NUMBER (FLOAT NUMBER)
						       \NUMSTR \NUMSTR1 (\CHECKFLTFMT
 FORMAT)))
		  (T (\CONVERTNUMBER
 (OR (FIXP NUMBER)
					 (FIXR NUMBER))
				     (COND
				       ((SETQ RAD (fetch
 RADIX of
 FMT))
					 (SETQ TEMP (IABS RAD))
					 (COND
					   ((OR (IGREATERP 2 TEMP)
						(IGREATERP TEMP 16))
					     (\ILLEGAL.ARG RAD)))
					 TEMP)
				       (T 10))
				     (OR (NULL RAD)
					 (IGREATERP RAD 0))
				     NIL \NUMSTR \NUMSTR1]
	      (SETQ PAD (COND
		  (WIDTH (IDIFFERENCE WIDTH (NCHARS STR)))
		  (T 0)))
	      [COND
		([AND (IGREATERP PAD 0)
		      (OR FLOATFLAG (NULL (fetch
 LEFTFLUSH of
 FMT]
		  (COND
		    ((COND
			(FLOATFLAG (fetch
 (FLOATFMT PAD0) of
 FMT))
			(T (fetch
 (FIXFMT PAD0) of
 FMT)))
		      (FRPTQ PAD (PRIN1
 "0" FILE)))
		    (T (SPACES
 PAD FILE]
	      (PRIN1
 STR FILE)
	      (COND
		((AND (IGREATERP PAD 0)
		      (NOT FLOATFLAG)
		      (fetch
 LEFTFLUSH of
 FMT))
		  (SPACES
 PAD FILE)))
	      (RETURN NUMBER)))])
)
(DECLARE: EVAL@COMPILE 

(PUTPROPS NUMFORMATCODE BYTEMACRO
 (= . PROG1))
)

(RPAQ? NILNUMPRINTFLG
 )
(MOVD? (QUOTE PRINTNUM)
       (QUOTE FPRINTNUM))
(DECLARE: DONTCOPY 
(DECLARE: EVAL@COMPILE 

(PUTPROPS .FILELINELENGTH. MACRO
 ((XOFD)
				  (COND
				    ((IGREATERP (fetch
 (STREAM LINELENGTH) of
 XOFD)
						0)
				      (fetch
 (STREAM LINELENGTH) of
 XOFD))
				    (T \LINELENGTH))))

(PUTPROPS .SPACECHECK. MACRO
 ((STRM N)
			      (AND \THISFILELINELENGTH (IGREATERP (IPLUS N (fetch
 CHARPOSITION
									      of
 STRM))
								  \THISFILELINELENGTH)
				   (FRESHLINE STRM))))

(PUTPROPS \PRODUCECHAR MACRO
 ((X)
			      (SPREADAPPLY* FN X)))
)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(SPECVARS \THISFILELINELENGTH)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(ADDTOVAR GLOBALVARS \CARPRINTLEVEL \TCARPRINTLEVEL \PRINTCRFLAG \CDRPRINTLEVEL \TCDRPRINTLEVEL 
	  \LINELENGTH \FLOATFORMAT \PRINTRADIX \SIGNFLAG PRXFLG \DEFPRINTFNS)
)
(DECLARE: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY 
(\APRINTINIT)
)
(PUTPROPS APRINT COPYRIGHT ("Xerox Corporation" 1982 1983 1984))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (1539 15216 (PRIN1 1549 . 2060) (PRIN2 2062 . 2624) (PRIN3 2626 . 3189) (PRIN4 3191 . 
3816) (PRINT 3818 . 4418) (PRINTLEVEL 4420 . 5004) (RADIX 5006 . 5498) (SPACES 5500 . 5845) (TERPRI 
5847 . 6034) (FRESHLINE 6036 . 6632) (DEFPRINT 6634 . 7076) (LINELENGTH 7078 . 7598) (\CKPOSBOUT 7600
 . 7764) (\CKPOSSOUT 7766 . 7979) (\CONVERTNUMBER 7981 . 9956) (\LITPRIN 9958 . 10742) (\OUTCHAR 10744
 . 10912) (\SOUT 10914 . 11078) (\PRINDATUM 11080 . 13668) (\PRINOTHER 13670 . 13954) (\PRINSTACKP 
13956 . 14348) (\PRINSTRING 14350 . 15214)) (15217 16347 (\FILEOUTCHARFN 15227 . 15988) (\TTYOUTCHARFN
 15990 . 16345)) (16348 19886 (\MAPCHARS 16358 . 16548) (\MAPCHARS1 16550 . 18670) (\PRODUCESTRING 
18672 . 18844) (\PRODUCENUM 18846 . 19078) (\PRODUCEADDR 19080 . 19605) (\MAPCHARSLIT 19607 . 19884)) 
(19887 20512 (\APRINTINIT 19897 . 20510)) (20799 23672 (FLTFMT 20809 . 21112) (\CHECKFLTFMT 21114 . 
21567) (NUMFORMATCODE 21569 . 21910) (PRINTNUM 21912 . 23670)))))
STOP