(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)

(FILECREATED "16-May-90 14:19:58" {DSK}<usr>local>lde>lispcore>sources>CMLPRINT.;2
 9569   

      changes to%:  (VARS CMLPRINTCOMS)

      previous date%: "16-Feb-88 11:47:48" {DSK}<usr>local>lde>lispcore>sources>CMLPRINT.;1)


(* ; "
Copyright (c) 1985, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT CMLPRINTCOMS)

(RPAQQ CMLPRINTCOMS

       [(FNS WRITE CL:WRITE-CHAR CL:PRIN1 CL:PRINT CL:TERPRI CL:FRESH-LINE CL:FINISH-OUTPUT 
             CL:FORCE-OUTPUT CL:CLEAR-OUTPUT CL:PPRINT CL:PRINC)
        (FUNCTIONS \WRITE1)
        (FNS CL:WRITE-TO-STRING CL:PRIN1-TO-STRING CL:PRINC-TO-STRING)
        (FUNCTIONS CL:WRITE-LINE)
        (INITVARS (XCL:*PRINT-STRUCTURE*))
        (PROP FILETYPE CMLPRINT)
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA)
                      (NLAML)
                      (LAMA CL:WRITE-TO-STRING CL:PRINC CL:PPRINT CL:PRINT CL:PRIN1 CL:WRITE-CHAR 
                            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*))                        (* ; "Edited 20-Feb-87 16:56 by bvm:")

         (DECLARE
 (CL: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))             (* ; 
                                                  "Make sure STREAM ends up as an appropriate stream")

         (SETQ
 STREAM (\GETSTREAM
 STREAM 'OUTPUT))
         [COND

            ((OR
 (NOT
 *PRINT-CIRCLE*)
                    *PRINT-CIRCLE-HASHTABLE*)
             (\WRITE1
 OBJECT STREAM))
            (T (LET
 ((*PRINT-CIRCLE-NUMBER* 1)
                         (*PRINT-CIRCLE-HASHTABLE* (CL:MAKE-HASH-TABLE
))
                         THERE-ARE-CIRCLES)
                      (DECLARE
 (CL:SPECIAL *PRINT-CIRCLE-NUMBER* *PRINT-CIRCLE-HASHTABLE* 
                                          THERE-ARE-CIRCLES))
                      (PRINT-CIRCLE-SCAN
 OBJECT)
                      (COND

                         ((NOT
 THERE-ARE-CIRCLES)
                          (CL:SETQ
 *PRINT-CIRCLE-HASHTABLE* NIL)))
                      (\WRITE1
 OBJECT STREAM]
         OBJECT))

(CL:WRITE-CHAR

  (CL:LAMBDA (CHARACTER
 &OPTIONAL OUTPUT-STREAM)         (* ; "Edited 20-Feb-87 16:57 by bvm:")

         (\OUTCHAR
 (\GETSTREAM
 OUTPUT-STREAM 'OUTPUT)
                (CL:CHAR-INT
 CHARACTER))
         CHARACTER))

(CL:PRIN1

  (CL:LAMBDA (OBJECT &OPTIONAL OUTPUT-STREAM)                (* ; "Edited 20-Feb-87 16:58 by bvm:")

         (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*])

(CL:FRESH-LINE

  [LAMBDA (OUTPUT-STREAM)                                    (* bvm%: "19-May-86 15:53")
    (FRESHLINE
 (OR
 OUTPUT-STREAM *STANDARD-OUTPUT*])

(CL:FINISH-OUTPUT

  [LAMBDA (OUTPUT-STREAM)                                    (* bvm%: "19-May-86 15:53")
    (FORCEOUTPUT
 (OR
 OUTPUT-STREAM *STANDARD-OUTPUT*)
           T)
    NIL])

(CL:FORCE-OUTPUT

  [LAMBDA (OUTPUT-STREAM)                                    (* bvm%: "19-May-86 15:53")
    (FORCEOUTPUT
 (OR
 OUTPUT-STREAM *STANDARD-OUTPUT*))
    NIL])

(CL:CLEAR-OUTPUT

  [LAMBDA (OUTPUT-STREAM)                                    (* bvm%: "19-May-86 15:38")
    NIL])

(CL: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)
         (CL:VALUES
)))

(CL:PRINC

  (CL:LAMBDA (OBJECT &OPTIONAL OUTPUT-STREAM)                (* ; "Edited 20-Feb-87 16:59 by bvm:")

         (WRITE
 OBJECT :STREAM OUTPUT-STREAM :ESCAPE NIL)))
)

(CL:DEFUN \WRITE1
 (OBJECT STREAM)
   (CL:IF (AND *PRINT-PRETTY* (OR (NOT *PRINT-CIRCLE*)
                                  (NOT *PRINT-CIRCLE-HASHTABLE*))
               *PRINT-ESCAPE*)

       (* ;; 

"If :pretty is on, and either :circle is not, or it was and no circles exist, and :escape is on...")


       (* ;; "For the moment, *PRINT-CIRCLE* and *PRINT-ESCAPE*  override *PRINT-PRETTY* completely. This leaves *PRINT-LEVEL* AND *PRINT-LENGTH* ignored when *PRINT-PRETTY* is on; this must be fixed later... probably by a new pretty-printer (ecch).")


       (LET (FONTCHANGEFLG)
            (DECLARE
 (CL:SPECIAL FONTCHANGEFLG))
            (PRINTDEF OBJECT (POSITION STREAM)
                   NIL NIL NIL STREAM))

       (* ;; "otherwise just print it all on one line")


       (LET (\THISFILELINELENGTH)
            (DECLARE
 (CL:SPECIAL \THISFILELINELENGTH))

            (* ;; "CommonLisp streams do not observe line length")


            (\PRINDATUM OBJECT (\GETSTREAM STREAM 'OUTPUT)
                   0))))
(DEFINEQ

(CL: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)))

(CL: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])

(CL: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])
)

(CL:DEFUN CL:WRITE-LINE
 (STRING &OPTIONAL (STREAM *STANDARD-OUTPUT*)
                                   &KEY
                                   (CL::START 0)
                                   CL::END)
   (PROG1 (WRITE-STRING* STRING STREAM CL::START CL::END)
          (CL:TERPRI
 STREAM)))

(RPAQ? XCL:*PRINT-STRUCTURE*
 )

(PUTPROPS CMLPRINT
 FILETYPE
 :FAKE-COMPILE-FILE)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 CL:WRITE-TO-STRING CL:PRINC CL:PPRINT CL:PRINT CL:PRIN1 CL:WRITE-CHAR WRITE)
)
(PRETTYCOMPRINT CMLPRINTCOMS)

(RPAQQ CMLPRINTCOMS

       [(FNS WRITE CL:WRITE-CHAR CL:PRIN1 CL:PRINT CL:TERPRI CL:FRESH-LINE CL:FINISH-OUTPUT 
             CL:FORCE-OUTPUT CL:CLEAR-OUTPUT CL:PPRINT CL:PRINC)
        (FUNCTIONS \WRITE1)
        (FNS CL:WRITE-TO-STRING CL:PRIN1-TO-STRING CL:PRINC-TO-STRING)
        (FUNCTIONS CL:WRITE-LINE)
        (INITVARS (XCL:*PRINT-STRUCTURE*))
        (PROP FILETYPE CMLPRINT)
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA)
                      (NLAML)
                      (LAMA CL:WRITE-TO-STRING CL:PPRINT CL:PRINT WRITE])
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 CL:WRITE-TO-STRING CL:PPRINT CL:PRINT WRITE)
)
(PUTPROPS CMLPRINT COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1101 5377 (WRITE 1111 . 3322) (CL:WRITE-CHAR 3324 . 3571) (CL:PRIN1 3573 . 3749) (
CL:PRINT 3751 . 4057) (CL:TERPRI 4059 . 4220) (CL:FRESH-LINE 4222 . 4390) (CL:FINISH-OUTPUT 4392 . 
4588) (CL:FORCE-OUTPUT 4590 . 4772) (CL:CLEAR-OUTPUT 4774 . 4893) (CL:PPRINT 4895 . 5195) (CL:PRINC 
5197 . 5375)) (6431 8056 (CL:WRITE-TO-STRING 6441 . 7451) (CL:PRIN1-TO-STRING 7453 . 7747) (
CL:PRINC-TO-STRING 7749 . 8054)))))
STOP