(FILECREATED "25-Jun-86 16:02:38" {ERIS}<LISPCORE>LIBRARY>CMLPRINT.;22 8900
changes to: (VARS CMLPRINTCOMS)
(FUNCTIONS WRITE-LINE)
previous date: "17-Jun-86 14:32:00" {ERIS}<LISPCORE>LIBRARY>CMLPRINT.;21)
(* 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)
(FUNCTIONS WRITE-LINE)
(* WRITE-STRING is in CMLSTREAMS)
(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])
(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: "17-Jun-86 13:59")
(DECLARE (SPECIAL *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 *PRINT-CIRCLE-HASHTABLE* (\WRITE1 OBJECT STREAM)
(LET ((*PRINT-CIRCLE-NUMBER* 1)
(*PRINT-CIRCLE-HASHTABLE* (MAKE-HASH-TABLE))
THERE-ARE-CIRCLES)
(DECLARE (SPECIAL *PRINT-CIRCLE-NUMBER*
*PRINT-CIRCLE-HASHTABLE* THERE-ARE-CIRCLES
))
(PRINT-CIRCLE-SCAN OBJECT)
(CL:IF (NOT THERE-ARE-CIRCLES)
(CL:SETQ *PRINT-CIRCLE-HASHTABLE* NIL))
(\WRITE1 OBJECT STREAM)))
(\WRITE1 OBJECT STREAM))
OBJECT))
(\WRITE1
[CL:LAMBDA (OBJECT STREAM)
(DECLARE (SPECIAL *PRINT-ESCAPE* *PRINT-RADIX* *PRINT-BASE* *PRINT-LEVEL* *PRINT-LENGTH*
*PRINT-CASE* *PRINT-GENSYM* *PRINT-ARRAY* *PRINT-PRETTY* *PRINT-CIRCLE*
\THISFILELINELENGTH)) (* jrb: "17-Jun-86 14:05")
(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 (SPECIAL \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])
)
(DEFUN WRITE-LINE (STRING &OPTIONAL (STREAM *STANDARD-OUTPUT*)
&KEY
(START 0)
(END (CL:LENGTH STRING))) (PROG1 (WRITE-STRING STRING STREAM :START START
:END END)
(CL:TERPRI STREAM)))
(* WRITE-STRING is in CMLSTREAMS)
(RPAQ? *PRINT-STRUCTURE* )
(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 (1082 6494 (WRITE 1092 . 3251) (\WRITE1 3253 . 4343) (WRITE-CHAR 4345 . 4630) (CL:PRIN1
4632 . 4863) (CL:PRINT 4865 . 5152) (CL:TERPRI 5154 . 5314) (FRESH-LINE 5316 . 5480) (FINISH-OUTPUT
5482 . 5674) (FORCE-OUTPUT 5676 . 5854) (CLEAR-OUTPUT 5856 . 5979) (PPRINT 5981 . 6260) (PRINC 6262 .
6492)) (6495 8152 (WRITE-TO-STRING 6505 . 7505) (PRIN1-TO-STRING 7507 . 7803) (PRINC-TO-STRING 7805 .
8150)))))
STOP