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

(FILECREATED "18-Oct-93 14:35:18" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLPRINT.;2"
 16374  

      previous date%: " 8-Jul-92 17:21:55" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLPRINT.;1")


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

(PRETTYCOMPRINT CMLPRINTCOMS)

(RPAQQ CMLPRINTCOMS

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

(WRITE

  (LISP: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*)
                      ((:PPRINT-DISPATCH XP:*PRINT-PPRINT-DISPATCH*)
                       XP:*PRINT-PPRINT-DISPATCH*)
                      ((:RIGHT-MARGIN XP:*PRINT-RIGHT-MARGIN*)
                       XP:*PRINT-RIGHT-MARGIN*)
                      ((:LINES XP:*PRINT-LINES*)
                       XP:*PRINT-LINES*)
                      ((:MISER-WIDTH XP:*PRINT-MISER-WIDTH*)
                       XP:*PRINT-MISER-WIDTH*)
                      ((:READABLY LISP:*PRINT-READABLY*)
                       LISP:*PRINT-READABLY*))               (* ; "Edited 11-Oct-91 23:23 by jrb:")

         (DECLARE
 (LISP:SPECIAL *PRINT-ESCAPE* *PRINT-RADIX* *PRINT-BASE* *PRINT-LEVEL* 
                             *PRINT-LENGTH* *PRINT-CASE* *PRINT-GENSYM* *PRINT-ARRAY* *PRINT-PRETTY*
                             *PRINT-CIRCLE* XP:*PRINT-PPRINT-DISPATCH* XP:*PRINT-RIGHT-MARGIN* 
                             XP:*PRINT-LINES* XP:*PRINT-MISER-WIDTH* LISP:*PRINT-READABLY* 
                             *PRINT-CIRCLE-HASHTABLE* *PRINT-CIRCLE-NUMBER* THERE-ARE-CIRCLES))
                                                             (* ; 

                                                "Make sure STREAM ends up as an appropriate stream")

         (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
         (LISP:WHEN LISP:*PRINT-READABLY* (HANDLE-PRINT-READABLY))
         [COND
            [*PRINT-PRETTY* (COND
                               ((XP::XP-STRUCTURE-P STREAM)
                                (XP::WRITE+ OBJECT STREAM))
                               (T (XP::MAYBE-INITIATE-XP-PRINTING #'(LISP:LAMBDA (LISP::S LISP::O)
                                                                           (XP::WRITE+ LISP::O 
                                                                                  LISP::S))
                                         STREAM OBJECT]
            ((OR (NOT *PRINT-CIRCLE*)
                 *PRINT-CIRCLE-HASHTABLE*)
             (\WRITE1
 OBJECT STREAM))
            (T (LET ((*PRINT-CIRCLE-NUMBER* 1)
                     (*PRINT-CIRCLE-HASHTABLE* (LISP:MAKE-HASH-TABLE))
                     THERE-ARE-CIRCLES)
                    (DECLARE
 (LISP:SPECIAL *PRINT-CIRCLE-NUMBER* *PRINT-CIRCLE-HASHTABLE* 
                                        THERE-ARE-CIRCLES))
                    (PRINT-CIRCLE-SCAN OBJECT)
                    (COND
                       ((NOT THERE-ARE-CIRCLES)
                        (LISP:SETQ *PRINT-CIRCLE-HASHTABLE* NIL)))
                    (\WRITE1
 OBJECT STREAM]
         OBJECT))

(LISP:WRITE-CHAR

  (LISP:LAMBDA (CHARACTER &OPTIONAL STREAM)                  (* ; "Edited 11-Oct-91 23:44 by jrb:")

         (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
         [COND
            ((AND *PRINT-PRETTY* (XP::XP-STRUCTURE-P STREAM))
             (XP::WRITE-CHAR+ CHARACTER STREAM))
            [LISP:*PRINT-READABLY* (LET ((*PRINT-ESCAPE* T))
                                        (\OUTCHAR STREAM (LISP:CHAR-INT CHARACTER]
            (T (\OUTCHAR STREAM (LISP:CHAR-INT CHARACTER]
         CHARACTER))

(LISP:PRIN1

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

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

(LISP:PRINT

  (LISP:LAMBDA (OBJECT &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (* ; "Edited 20-Oct-91 21:16 by jrb:")

         (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))

         (* ;; "The *PRINT-READABLY* case is forced through PRIN1 which goes through WRITE which rebinds everything as necessary")


         (COND
            [(AND *PRINT-PRETTY* (NOT LISP:*PRINT-READABLY*))
             (COND
                ((XP::XP-STRUCTURE-P STREAM)
                 (XP::PPRINT-NEWLINE+ :UNCONDITIONAL STREAM)
                 (LET ((*PRINT-ESCAPE* T))
                      (XP::BASIC-WRITE OBJECT STREAM)
                      (XP::WRITE-CHAR++ #\Space STREAM)))
                (T (XP::MAYBE-INITIATE-XP-PRINTING #'(LISP:LAMBDA (LISP::S LISP::O)
                                                            (XP::WRITE+ LISP::O LISP::S))
                          STREAM OBJECT]
            (T (TERPRI STREAM)
               (LISP:PRIN1
 OBJECT STREAM)
               (SPACES 1 STREAM)))
         OBJECT))

(LISP:TERPRI

  [LAMBDA (STREAM)                                           (* ; "Edited 20-Sep-91 13:56 by jrb:")


    (* ;; "The clause *PRINT-PRETTY* is not necessary here: if a TERPRI is the first printing operation in a pretty-print sequence, it will be ignored anyway.")


    (COND
       ((AND *PRINT-PRETTY* (XP::XP-STRUCTURE-P STREAM))
        (XP::PPRINT-NEWLINE+ :UNCONDITIONAL STREAM))
       (T (TERPRI (OR STREAM *STANDARD-OUTPUT*])

(LISP:FRESH-LINE

  [LAMBDA (STREAM)                                           (* ; "Edited 20-Sep-91 13:57 by jrb:")

    (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
    (COND
       ((AND *PRINT-PRETTY* (XP::XP-STRUCTURE-P STREAM))
        (XP::ATTEMPT-TO-OUTPUT STREAM T T)                   (* ; "ok because we want newline")

        (LISP:WHEN (NOT (LISP:ZEROP (XP::LP<-BP STREAM)))
            (XP::PPRINT-NEWLINE+ :FRESH STREAM)
            T))
       (T (FRESHLINE STREAM])

(LISP:FINISH-OUTPUT

  [LAMBDA (STREAM)                                           (* ; "Edited 20-Sep-91 14:01 by jrb:")

    (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
    (LISP:IF (XP::XP-STRUCTURE-P STREAM)
           (XP::ATTEMPT-TO-OUTPUT STREAM T T))
    (FORCEOUTPUT STREAM T)
    NIL])

(LISP:FORCE-OUTPUT

  [LAMBDA (STREAM)                                           (* ; "Edited 20-Sep-91 14:01 by jrb:")

    (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
    (LISP:IF (XP::XP-STRUCTURE-P STREAM)
           (XP::ATTEMPT-TO-OUTPUT STREAM T T))
    (FORCEOUTPUT STREAM)
    NIL])

(LISP:CLEAR-OUTPUT

  [LAMBDA (STREAM)                                           (* ; "Edited 20-Sep-91 13:14 by jrb:")

    (LISP:IF [XP::XP-STRUCTURE-P (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT]
        (LET ((XP::*LOCATING-CIRCULARITIES* 0))              (* ; "hack to prevent visible output")

             (XP::ATTEMPT-TO-OUTPUT STREAM T T)))
    NIL])

(LISP:PPRINT

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

(LISP:PRINC

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

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

(LISP:DEFUN \WRITE1
 (OBJECT STREAM)

   (* ;; "This used to be where we decided if we were pretty-printing or not; the conditionality was a little strange:")


   (* ;; "(CL:IF (AND *PRINT-PRETTY* (OR (NOT *PRINT-CIRCLE*) (NOT *PRINT-CIRCLE-HASHTABLE*)) *PRINT-ESCAPE*) (pretty-print-using-IL:PRINTDEF) (just-print))")


   (* ;; "I don't remember why *PRINT-ESCAPE* was tested; I suspect PRINTDEF forces it on.  Anyway, we're not using PRINTDEF any more here, I hope.")


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


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

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


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

(LISP:WRITE-TO-STRING

  (LISP: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*)
                      ((:PPRINT-DISPATCH XP:*PRINT-PPRINT-DISPATCH*)
                       XP:*PRINT-PPRINT-DISPATCH*)
                      ((:RIGHT-MARGIN XP:*PRINT-RIGHT-MARGIN*)
                       XP:*PRINT-RIGHT-MARGIN*)
                      ((:LINES XP:*PRINT-LINES*)
                       XP:*PRINT-LINES*)
                      ((:MISER-WIDTH XP:*PRINT-MISER-WIDTH*)
                       XP:*PRINT-MISER-WIDTH*)
                      ((:READABLY LISP:*PRINT-READABLY*)
                       LISP:*PRINT-READABLY*))               (* ; "Edited 11-Oct-91 23:58 by jrb:")

         "Returns the printed representation of OBJECT as a string."
         (LISP:WHEN LISP:*PRINT-READABLY* (HANDLE-PRINT-READABLY))
         (LISP:IF *PRINT-PRETTY*
             (LISP:WITH-OUTPUT-TO-STRING (LISP::S)
                    (WRITE
 OBJECT :STREAM LISP::S))
             (\PRINDATUM.TO.STRING OBJECT))))

(LISP:PRIN1-TO-STRING

  [LAMBDA (OBJECT)                                           (* ; "Edited 20-Oct-91 21:25 by jrb:")


(* ;;; "Produces a string consisting of the output of (PRIN1 OBJECT)")


    (LET ((*PRINT-ESCAPE* T))

         (* ;; 

"We force the *PRINT-READABLY* case through WRITE-TO-STRING to let it rebind the control variables ")


         (COND
            (LISP:*PRINT-READABLY* (LISP:WRITE-TO-STRING
 OBJECT))
            (*PRINT-PRETTY* (LISP:WITH-OUTPUT-TO-STRING (LISP::S)
                                   (WRITE
 OBJECT :STREAM LISP::S)))
            (T (\PRINDATUM.TO.STRING OBJECT])

(LISP:PRINC-TO-STRING

  [LAMBDA (OBJECT)                                           (* ; "Edited 20-Oct-91 21:24 by jrb:")


(* ;;; 

"A lot like MKSTRING, but not quite.  Produces a string consisting of the output of (PRINC OBJECT)")


    (LET ((*PRINT-ESCAPE* NIL))

         (* ;; 

"We force the *PRINT-READABLY* case through WRITE-TO-STRING to let it rebind the control variables ")


         (COND
            (LISP:*PRINT-READABLY* (LISP:WRITE-TO-STRING
 OBJECT))
            (*PRINT-PRETTY* (LISP:WITH-OUTPUT-TO-STRING (LISP::S)
                                   (WRITE
 OBJECT :STREAM LISP::S)))
            (T (\PRINDATUM.TO.STRING OBJECT])
)
(DEFINEQ

(WRITE-STRING*

  [LAMBDA (STRING STREAM START END)                          (* ; "Edited 21-Oct-91 13:20 by jrb:")

    (OR STREAM (SETQ STREAM *STANDARD-OUTPUT*))
    (LISP:UNLESS (EQ LISP:*PRINT-READABLY* 'XCL::PRINTING-READABLY)
        (LISP::CHECK-READABLY STRING 'WRITE-STRING*))
    (LISP:IF (AND *PRINT-PRETTY* (XP::XP-STRUCTURE-P STREAM))
        (XP::WRITE-STRING+ STRING STREAM START END)
        [LET ((STRING-LENGTH (LISP:LENGTH STRING)))
             (OR START (SETQ START 0))
             (LISP:CHECK-TYPE STRING STRING)
             (LISP:WHEN (NULL END)
                    (SETQ END STRING-LENGTH))
             (LISP:ASSERT (AND (<= 0 START STRING-LENGTH)
                               (<= START END STRING-LENGTH))
                    '(START END)
                    "Start (~D) or end (~D) argument out of bounds." START END)

             (* ;; "The following comes mainly from \PRINSTRING...")


             (LET ((CHARS-TO-PRINT (- END START))
                   \THISFILELINELENGTH)
                  (DECLARE
 (SPECVARS \THISFILELINELENGTH))
                  (LISP:WHEN (LISP:PLUSP CHARS-TO-PRINT)
                      (.SPACECHECK. STREAM CHARS-TO-PRINT)

                      (* ;; "Essentially (for x instring string do (\outchar strm x)).")


                      (LISP:DO [(FATP (ffetch
 (STRINGP FATSTRINGP) of
 STRING))
                                (BASE (ffetch
 (STRINGP BASE) of
 STRING))
                                (OFFSET (IPLUS START (ffetch
 (STRINGP OFFST) of
 STRING))
                                       (ADD1 OFFSET))
                                (END (IPLUS END (ffetch
 (STRINGP OFFST) of
 STRING]
                               ((>= OFFSET END))
                          (\OUTCHAR STREAM (LISP:IF FATP
                                               (\GETBASEFAT BASE OFFSET)
                                               (\GETBASETHIN BASE OFFSET)))))])
    STRING])
)

(LISP:DEFUN LISP:WRITE-STRING
 (STRING &OPTIONAL (STREAM *STANDARD-OUTPUT*)
                                         &KEY
                                         (START 0)
                                         (END (LISP:LENGTH STRING)))
                                                             (* ; "Edited  6-May-92 13:23 by jrb:")

   (WRITE-STRING*
 STRING (\GETSTREAM STREAM 'OUTPUT)
          START END)
   STRING)

(LISP:DEFUN LISP:WRITE-LINE
 (STRING &OPTIONAL (STREAM *STANDARD-OUTPUT*)
                                       &KEY
                                       (LISP::START 0)
                                       LISP::END)
   (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
   (LISP:UNLESS (EQ LISP:*PRINT-READABLY* 'XCL::PRINTING-READABLY)
       (LISP::CHECK-READABLY STRING 'LISP:WRITE-LINE))
   (COND
      ((AND *PRINT-PRETTY* (XP::XP-STRUCTURE-P STREAM))
       (PROGN (XP::WRITE-STRING+ STRING STREAM LISP::START LISP::END)
              (XP::PPRINT-NEWLINE+ :UNCONDITIONAL STREAM)))
      (T (WRITE-STRING*
 STRING STREAM LISP::START LISP::END)
         (LISP:TERPRI
 STREAM)))
   STRING)

(RPAQ? XCL:*PRINT-STRUCTURE*
 )

(LISP:DEFVAR LISP:*PRINT-READABLY*
 NIL)

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

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 LISP:WRITE-TO-STRING LISP:PRINC LISP:PPRINT LISP:PRINT LISP:PRIN1 LISP:WRITE-CHAR
                         WRITE)
)
(PUTPROPS CMLPRINT COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1991 1992 1993))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1214 8835 (WRITE 1224 . 4704) (LISP:WRITE-CHAR 4706 . 5230) (LISP:PRIN1 5232 . 5413) 
(LISP:PRINT 5415 . 6424) (LISP:TERPRI 6426 . 6882) (LISP:FRESH-LINE 6884 . 7373) (LISP:FINISH-OUTPUT 
7375 . 7675) (LISP:FORCE-OUTPUT 7677 . 7974) (LISP:CLEAR-OUTPUT 7976 . 8342) (LISP:PPRINT 8344 . 8646)
 (LISP:PRINC 8648 . 8833)) (9611 12737 (LISP:WRITE-TO-STRING 9621 . 11419) (LISP:PRIN1-TO-STRING 11421
 . 12054) (LISP:PRINC-TO-STRING 12056 . 12735)) (12738 14726 (WRITE-STRING* 12748 . 14724)))))
STOP