(FILECREATED "12-Jun-86 23:43:17" {ERIS}<LISPCORE>LIBRARY>CMLPRINT.;20 9263
changes to: (VARS CMLPRINTCOMS)
(FNS WRITE \WRITE1 PRINT-CIRCLE-ENTER PRINT-CIRCLE-LOOKUP PRINT-CIRCLE-LABEL-P
PRINT-CIRCLE-SCAN)
previous date: "19-May-86 15:56:09" {ERIS}<LISPCORE>LIBRARY>CMLPRINT.;18)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLPRINTCOMS)
(RPAQQ CMLPRINTCOMS
[(FNS WRITE \WRITE1 WRITE-CHAR CL:PRIN1 CL:PRINT CL:TERPRI FRESH-LINE FINISH-OUTPUT
FORCE-OUTPUT CLEAR-OUTPUT PPRINT PRINC)
(FNS WRITE-TO-STRING PRIN1-TO-STRING PRINC-TO-STRING)
(INITVARS (*PRINT-STRUCTURE*))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA PRINT-CIRCLE-SCAN PRINT-CIRCLE-LABEL-P PRINT-CIRCLE-LOOKUP
PRINT-CIRCLE-ENTER WRITE-TO-STRING PRINC PPRINT CL:PRINT CL:PRIN1
WRITE-CHAR \WRITE1 WRITE])
(DEFINEQ
(WRITE
(CL:LAMBDA (OBJECT &KEY (STREAM *STANDARD-OUTPUT*)
((:ESCAPE *PRINT-ESCAPE*)
*PRINT-ESCAPE*)
((:RADIX *PRINT-RADIX*)
*PRINT-RADIX*)
((:BASE *PRINT-BASE*)
*PRINT-BASE*)
((:LEVEL *PRINT-LEVEL*)
*PRINT-LEVEL*)
((:LENGTH *PRINT-LENGTH*)
*PRINT-LENGTH*)
((:CASE *PRINT-CASE*)
*PRINT-CASE*)
((:GENSYM *PRINT-GENSYM*)
*PRINT-GENSYM*)
((:ARRAY *PRINT-ARRAY*)
*PRINT-ARRAY*)
((:PRETTY *PRINT-PRETTY*)
*PRINT-PRETTY*)
((:CIRCLE *PRINT-CIRCLE*)
*PRINT-CIRCLE*)) (* jrb: "11-Jun-86 14:38")
(DECLARE (SPECVARS *PRINT-ESCAPE* *PRINT-RADIX* *PRINT-BASE* *PRINT-LEVEL* *PRINT-LENGTH*
*PRINT-CASE* *PRINT-GENSYM* *PRINT-ARRAY* *PRINT-PRETTY* *PRINT-CIRCLE*
*PRINT-CIRCLE-HASHTABLE* *PRINT-CIRCLE-NUMBER* THERE-ARE-CIRCLES))
(CL:IF *PRINT-CIRCLE* [CL:IF (BOUNDP (QUOTE THERE-ARE-CIRCLES))
(\WRITE1 OBJECT STREAM)
(LET ((*PRINT-CIRCLE-NUMBER* 1)
THERE-ARE-CIRCLES)
(DECLARE (SPECVARS *PRINT-CIRCLE-NUMBER* THERE-ARE-CIRCLES
))
(PRINT-CIRCLE-SCAN OBJECT)
(UNWIND-PROTECT (\WRITE1 OBJECT STREAM)
(CLRHASH *PRINT-CIRCLE-HASHTABLE*]
(\WRITE1 OBJECT STREAM))
OBJECT))
(\WRITE1
[CL:LAMBDA (OBJECT STREAM)
(DECLARE (SPECVARS *PRINT-ESCAPE* *PRINT-RADIX* *PRINT-BASE* *PRINT-LEVEL* *PRINT-LENGTH*
*PRINT-CASE* *PRINT-GENSYM* *PRINT-ARRAY* *PRINT-PRETTY* *PRINT-CIRCLE*
\THISFILELINELENGTH)) (* jrb: "12-Jun-86 18:11")
(CL:BLOCK \WRITE1 (COND
(*PRINT-PRETTY* (*
"For the moment, *PRINT-PRETTY* overrides *PRINT-CIRCLE* completely")
(PRINTDEF OBJECT NIL NIL NIL NIL STREAM))
(T (LET (\THISFILELINELENGTH)
(DECLARE (SPECVARS \THISFILELINELENGTH))
(* CommonLisp streams do not observe
line length)
(\PRINDATUM OBJECT (\GETSTREAM STREAM (QUOTE OUTPUT))
0])
(WRITE-CHAR
(CL:LAMBDA (CHARACTER &OPTIONAL (OUTPUT-STREAM *STANDARD-OUTPUT*))
(* jrb: "15-May-86 18:17")
(\OUTCHAR (\GETSTREAM OUTPUT-STREAM (QUOTE OUTPUT))
(CHAR-INT CHARACTER))
CHARACTER))
(CL:PRIN1
(CL:LAMBDA (OBJECT &OPTIONAL (OUTPUT-STREAM *STANDARD-OUTPUT*))
(* lmm " 4-May-86 03:15")
(WRITE OBJECT :STREAM OUTPUT-STREAM :ESCAPE T)))
(CL:PRINT
(CL:LAMBDA (OBJECT &OPTIONAL (OUTPUT-STREAM *STANDARD-OUTPUT*))
(* lmm " 4-May-86 03:15")
(TERPRI OUTPUT-STREAM)
(PROG1 (CL:PRIN1 OBJECT OUTPUT-STREAM)
(SPACES 1 OUTPUT-STREAM))))
(CL:TERPRI
[LAMBDA (OUTPUT-STREAM) (* bvm: "19-May-86 15:53")
(TERPRI (OR OUTPUT-STREAM *STANDARD-OUTPUT*])
(FRESH-LINE
[LAMBDA (OUTPUT-STREAM) (* bvm: "19-May-86 15:53")
(FRESHLINE (OR OUTPUT-STREAM *STANDARD-OUTPUT*])
(FINISH-OUTPUT
[LAMBDA (OUTPUT-STREAM) (* bvm: "19-May-86 15:53")
(FORCEOUTPUT (OR OUTPUT-STREAM *STANDARD-OUTPUT*)
T)
NIL])
(FORCE-OUTPUT
[LAMBDA (OUTPUT-STREAM) (* bvm: "19-May-86 15:53")
(FORCEOUTPUT (OR OUTPUT-STREAM *STANDARD-OUTPUT*))
NIL])
(CLEAR-OUTPUT
[LAMBDA (OUTPUT-STREAM) (* bvm: "19-May-86 15:38")
NIL])
(PPRINT
(CL:LAMBDA (OBJECT &OPTIONAL (OUTPUT-STREAM *STANDARD-OUTPUT*))
(* lmm " 4-May-86 03:19")
(TERPRI OUTPUT-STREAM)
(WRITE OBJECT :STREAM OUTPUT-STREAM :ESCAPE T :PRETTY T)
(VALUES)))
(PRINC
(CL:LAMBDA (OBJECT &OPTIONAL (OUTPUT-STREAM *STANDARD-OUTPUT*))
(* lmm " 4-May-86 03:20")
(WRITE OBJECT :STREAM OUTPUT-STREAM :ESCAPE NIL)))
)
(DEFINEQ
(WRITE-TO-STRING
(CL:LAMBDA (OBJECT &KEY ((:ESCAPE *PRINT-ESCAPE*)
*PRINT-ESCAPE*)
((:RADIX *PRINT-RADIX*)
*PRINT-RADIX*)
((:BASE *PRINT-BASE*)
*PRINT-BASE*)
((:CIRCLE *PRINT-CIRCLE*)
*PRINT-CIRCLE*)
((:PRETTY *PRINT-PRETTY*)
*PRINT-PRETTY*)
((:LEVEL *PRINT-LEVEL*)
*PRINT-LEVEL*)
((:LENGTH *PRINT-LENGTH*)
*PRINT-LENGTH*)
((:CASE *PRINT-CASE*)
*PRINT-CASE*)
((:ARRAY *PRINT-ARRAY*)
*PRINT-ARRAY*)
((:GENSYM *PRINT-GENSYM*)
*PRINT-GENSYM*)) (* bvm: "13-May-86 15:38")
"Returns the printed representation of OBJECT as a string."
(\PRINDATUM.TO.STRING OBJECT)))
(PRIN1-TO-STRING
[LAMBDA (OBJECT) (* bvm: "13-May-86 15:24")
(* * Produces a string consisting of the output of
(CL:PRIN1 OBJECT))
(LET ((*PRINT-ESCAPE* T))
(\PRINDATUM.TO.STRING OBJECT])
(PRINC-TO-STRING
[LAMBDA (OBJECT) (* bvm: "13-May-86 15:23")
(* * A lot like MKSTRING, but not quite.
Produces a string consisting of the output of
(PRINC OBJECT))
(LET ((*PRINT-ESCAPE* NIL))
(\PRINDATUM.TO.STRING OBJECT])
)
(RPAQ? *PRINT-STRUCTURE* )
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA PRINT-CIRCLE-SCAN PRINT-CIRCLE-LABEL-P PRINT-CIRCLE-LOOKUP PRINT-CIRCLE-ENTER
WRITE-TO-STRING PRINC PPRINT CL:PRINT CL:PRIN1 WRITE-CHAR \WRITE1 WRITE)
)
(PRETTYCOMPRINT CMLPRINTCOMS)
(RPAQQ CMLPRINTCOMS [(FNS WRITE \WRITE1 WRITE-CHAR CL:PRIN1 CL:PRINT CL:TERPRI FRESH-LINE
FINISH-OUTPUT FORCE-OUTPUT CLEAR-OUTPUT PPRINT PRINC)
(FNS WRITE-TO-STRING PRIN1-TO-STRING PRINC-TO-STRING)
(INITVARS (*PRINT-STRUCTURE*))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA WRITE-TO-STRING PRINC PPRINT CL:PRINT CL:PRIN1 WRITE-CHAR
\WRITE1 WRITE])
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA WRITE-TO-STRING PRINC PPRINT CL:PRINT CL:PRIN1 WRITE-CHAR \WRITE1 WRITE)
)
(PUTPROPS CMLPRINT COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1094 6323 (WRITE 1104 . 3078) (\WRITE1 3080 . 4172) (WRITE-CHAR 4174 . 4459) (CL:PRIN1
4461 . 4692) (CL:PRINT 4694 . 4981) (CL:TERPRI 4983 . 5143) (FRESH-LINE 5145 . 5309) (FINISH-OUTPUT
5311 . 5503) (FORCE-OUTPUT 5505 . 5683) (CLEAR-OUTPUT 5685 . 5808) (PPRINT 5810 . 6089) (PRINC 6091 .
6321)) (6324 7981 (WRITE-TO-STRING 6334 . 7334) (PRIN1-TO-STRING 7336 . 7632) (PRINC-TO-STRING 7634 .
7979)))))
STOP