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

(FILECREATED "18-Oct-93 14:20:56" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLMISCIO.;2"
 6473   

      |previous| |date:| "25-Oct-91 22:41:18" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLMISCIO.;1"
)


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

(PRETTYCOMPRINT CMLMISCIOCOMS)

(RPAQQ CMLMISCIOCOMS

       (
        (* |;;| "Random leftover IO functions")


        
        (* |;;| "[JDS 2/3/88: Removed FRESH-LINE from here, since it's also in CMLPRINT. AR #9601]")


        (FUNCTIONS LISP:Y-OR-N-P LISP:YES-OR-NO-P)
        
        (* |;;| "JRB - stuff that handles CL:*PRINT-READABLY*")


        (FUNCTIONS HANDLE-PRINT-READABLY LISP::CHECK-READABLY)
        (FUNCTIONS LISP:PRINT-UNREADABLE-OBJECT LISP:WITH-STANDARD-IO-SYNTAX)
        
        (* |;;| "Arrange to use the proper compiler")


        (PROP FILETYPE CMLMISCIO)))



(* |;;| "Random leftover IO functions")





(* |;;| "[JDS 2/3/88: Removed FRESH-LINE from here, since it's also in CMLPRINT. AR #9601]")



(LISP:DEFUN LISP:Y-OR-N-P
 (&OPTIONAL FORMAT-STRING &REST ARGUMENTS)
   (COND
      (FORMAT-STRING (LISP:FRESH-LINE)
             (LISP:APPLY (FUNCTION LISP:FORMAT)
                    *QUERY-IO* FORMAT-STRING ARGUMENTS)))
   (LISP:FLET ((LISP::READ-CHAR-NOW NIL (RESETFORM (CONTROL T)
                                                 (LISP:READ-CHAR *QUERY-IO*))))
          (LISP:DO ((LISP::RESPONSE (LISP::READ-CHAR-NOW)
                           (LISP::READ-CHAR-NOW)))
                   ((OR (LISP:CHAR-EQUAL LISP::RESPONSE #\Y)
                        (LISP:CHAR-EQUAL LISP::RESPONSE #\N))
                    (LISP:FRESH-LINE)
                    (LISP:CHAR-EQUAL LISP::RESPONSE #\Y))
              (LISP:FORMAT *QUERY-IO* "~&Please type either Y or N: "))))

(LISP:DEFUN LISP:YES-OR-NO-P
 (&OPTIONAL LISP::FORMAT-STRING &REST LISP::ARGUMENTS)
   (LISP:WHEN LISP::FORMAT-STRING
       (LISP:FRESH-LINE *QUERY-IO*)
       (LISP:APPLY #'LISP:FORMAT *QUERY-IO* LISP::FORMAT-STRING LISP::ARGUMENTS))
   (LISP:DO ((LISP::RESPONSE (LISP:READ-LINE *QUERY-IO*)
                    (LISP:READ-LINE *QUERY-IO*)))
            ((OR (STRING-EQUAL LISP::RESPONSE "YES")
                 (STRING-EQUAL LISP::RESPONSE "NO"))
             (STRING-EQUAL LISP::RESPONSE "YES"))
       (LISP:FORMAT *QUERY-IO* "Please type either YES or NO: ")))



(* |;;| "JRB - stuff that handles CL:*PRINT-READABLY*")



(LISP:DEFUN HANDLE-PRINT-READABLY
 ()

   (* |;;| "Strategy: when *PRINT-READABLY* is on, all CL top-level printing functions go through a function that rebinds all the printer control variables (like WRITE or WRITE-TO-STRING).  Calling HANDLE-PRINT-READABLY sets the control variables so output is printed readably; it also sets *PRINT-READABLY* to a magic value so functions like FORMAT and WRITE-STRING will know it's OK to write constant strings without munging them.")


   (SETQ *PRINT-ESCAPE* T)
   (SETQ *PRINT-LEVEL* NIL)
   (SETQ *PRINT-LENGTH* NIL)
   (SETQ *PRINT-GENSYM* T)
   (SETQ *PRINT-ARRAY* T)
   (SETQ *PRINT-CIRCLE* T)
   (SETQ XCL:*PRINT-STRUCTURE* T)
   (SETQ LISP:*PRINT-READABLY* 'XCL::PRINTING-READABLY))

(LISP:DEFUN LISP::CHECK-READABLY
 (XCL::THING &OPTIONAL LISP::WHERE)
   (LISP:WHEN LISP:*PRINT-READABLY*
       (LET (LISP:*PRINT-READABLY*)
            (CONDITIONS:RESTART-CASE (LISP:ERROR 'LISP::PRINT-NOT-READABLE :THING XCL::THING :WHERE 
                                            LISP::WHERE)
                   (XCL::PRINT-IT-ANYWAY NIL :REPORT (LISP:LAMBDA (STREAM)
                                                              (LISP:PRINC "Print it anyway " STREAM))
                          :FILTER
                          (LISP:LAMBDA NIL (TYPEP XCL:*CURRENT-CONDITION* 
                                                    'LISP::PRINT-NOT-READABLE)))))))

(DEFMACRO LISP:PRINT-UNREADABLE-OBJECT
 ((LISP::OBJECT STREAM &KEY TYPE LISP:IDENTITY)
                                            &BODY LISP::BODY)
   (LET ((LISP::O (LISP:GENSYM))
         (LISP::S (LISP:GENSYM))
         (LISP::SPACE? (LISP:GENSYM)))
        `(LET ((,LISP::O ,LISP::OBJECT)
               (,LISP::S ,STREAM)
               ,LISP::SPACE?)
              (LISP::CHECK-READABLY
 ,LISP::O)
              (WRITE-STRING* "#<" ,LISP::S)
              ,@(LISP:WHEN TYPE
                    `((LISP:WHEN ,TYPE
                          (LISP:SETQ ,LISP::SPACE? T)
                          (WRITE (LISP:TYPE-OF ,LISP::O)
                                 ,LISP::S))))
              ,@(LISP:WHEN LISP::BODY
                    `((LISP:WHEN ,LISP::SPACE?
                          (LISP:WRITE-CHAR #\Space ,LISP::S))
                      (PROGN ,@LISP::BODY (LISP:SETQ ,LISP::SPACE? T))))
              ,@(LISP:WHEN LISP:IDENTITY
                    `((LISP:WHEN ,LISP:IDENTITY
                          (LISP:WHEN ,LISP::SPACE?
                              (LISP:WRITE-CHAR #\Space ,LISP::S))
                          (WRITE-STRING* "@ " ,LISP::S)
                          (\\PRINTADDR ,LISP::O ,LISP::S))))
              (LISP:WRITE-CHAR #\> ,LISP::S)
              NIL)))

(DEFMACRO LISP:WITH-STANDARD-IO-SYNTAX
 (&BODY LISP::BODY)
   `(LET ((*PACKAGE* (LISP:FIND-PACKAGE "COMMON-LISP-USER"))
          (*PRINT-ARRAY* T)
          (*PRINT-BASE* 10)
          (*PRINT-CASE* :UPCASE)
          (*PRINT-CIRCLE* NIL)
          (*PRINT-ESCAPE* T)
          (*PRINT-GENSYM* T)
          (*PRINT-LENGTH* NIL)
          (*PRINT-LEVEL* NIL)
          (*PRINT-PRETTY* NIL)
          (*PRINT-RADIX* NIL)
          (LISP:*PRINT-READABLY* T)
          (*READ-BASE* 10)
          (*READ-DEFAULT-FLOAT-FORMAT* 'LISP:SINGLE-FLOAT)
          (LISP:*READ-EVAL* T)
          (*READ-SUPPRESS* NIL)
          (*READTABLE* (FIND-READTABLE "LISP"))

          (* |;;| "XP-specific variables")


          (XP:*PRINT-LINES* NIL)
          (XP:*PRINT-MISER-WIDTH* NIL)
          (XP:*PRINT-PPRINT-DISPATCH* NIL)
          (XP:*PRINT-RIGHT-MARGIN* NIL)

          (* |;;| "XCL-specific variables")


          (XCL:*PRINT-STRUCTURE* T))
         ,@LISP::BODY))



(* |;;| "Arrange to use the proper compiler")



(PUTPROPS CMLMISCIO
 FILETYPE
 LISP:COMPILE-FILE)
(PUTPROPS CMLMISCIO COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1993))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL)))
STOP