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

(IL:FILECREATED "16-May-90 21:23:08" IL:{DSK}<usr>local>lde>lispcore>sources>READ-PRINT-PROFILE.;2
 12400  

      IL:changes IL:to%:  (IL:VARS IL:READ-PRINT-PROFILECOMS)

      IL:previous IL:date%: "13-Nov-86 11:37:11" 
IL:{DSK}<usr>local>lde>lispcore>sources>READ-PRINT-PROFILE.;1)


(IL:* ; "
Copyright (c) 1986, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(IL:PRETTYCOMPRINT IL:READ-PRINT-PROFILECOMS)

(IL:RPAQQ IL:READ-PRINT-PROFILECOMS

          ((IL:P (EXPORT '(MAKE-READ-PRINT-PROFILE COPY-READ-PRINT-PROFILE READ-PRINT-PROFILE-P 
                                 READ-PRINT-PROFILE-READTABLE READ-PRINT-PROFILE-READ-BASE 
                                 READ-PRINT-PROFILE-READ-SUPPRESS READ-PRINT-PROFILE-PACKAGE 
                                 READ-PRINT-PROFILE-READ-DEFAULT-FLOAT-FORMAT 
                                 READ-PRINT-PROFILE-PRINT-ESCAPE READ-PRINT-PROFILE-PRINT-PRETTY 
                                 READ-PRINT-PROFILE-PRINT-CIRCLE READ-PRINT-PROFILE-PRINT-BASE 
                                 READ-PRINT-PROFILE-PRINT-RADIX READ-PRINT-PROFILE-PRINT-CASE 
                                 READ-PRINT-PROFILE-PRINT-GENSYM READ-PRINT-PROFILE-PRINT-LEVEL 
                                 READ-PRINT-PROFILE-PRINT-LENGTH READ-PRINT-PROFILE-PRINT-ARRAY 
                                 READ-PRINT-PROFILE-PRINT-STRUCTURE RESTORE-READ-PRINT-PROFILE 
                                 SAVE-READ-PRINT-PROFILE WITH-READ-PRINT-PROFILE 
                                 *DEFAULT-READ-PRINT-PROFILE* FIND-READ-PRINT-PROFILE 
                                 LIST-ALL-READ-PRINT-PROFILE-NAMES)
                        "XCL"))
           (IL:STRUCTURES READ-PRINT-PROFILE)
           (IL:FUNCTIONS MAKE-READ-PRINT-PROFILE RESTORE-READ-PRINT-PROFILE SAVE-READ-PRINT-PROFILE 
                  WITH-READ-PRINT-PROFILE FIND-READ-PRINT-PROFILE SETF-FIND-READ-PRINT-PROFILE 
                  LIST-ALL-READ-PRINT-PROFILE-NAMES)
           (IL:SETFS FIND-READ-PRINT-PROFILE)
           (IL:VARIABLES *READ-PRINT-PROFILES* *DEFAULT-READ-PRINT-PROFILE*)
           (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE)
                  IL:READ-PRINT-PROFILE)))

(EXPORT '(MAKE-READ-PRINT-PROFILE COPY-READ-PRINT-PROFILE READ-PRINT-PROFILE-P 
                READ-PRINT-PROFILE-READTABLE READ-PRINT-PROFILE-READ-BASE 
                READ-PRINT-PROFILE-READ-SUPPRESS READ-PRINT-PROFILE-PACKAGE 
                READ-PRINT-PROFILE-READ-DEFAULT-FLOAT-FORMAT READ-PRINT-PROFILE-PRINT-ESCAPE 
                READ-PRINT-PROFILE-PRINT-PRETTY READ-PRINT-PROFILE-PRINT-CIRCLE 
                READ-PRINT-PROFILE-PRINT-BASE READ-PRINT-PROFILE-PRINT-RADIX 
                READ-PRINT-PROFILE-PRINT-CASE READ-PRINT-PROFILE-PRINT-GENSYM 
                READ-PRINT-PROFILE-PRINT-LEVEL READ-PRINT-PROFILE-PRINT-LENGTH 
                READ-PRINT-PROFILE-PRINT-ARRAY READ-PRINT-PROFILE-PRINT-STRUCTURE 
                RESTORE-READ-PRINT-PROFILE SAVE-READ-PRINT-PROFILE WITH-READ-PRINT-PROFILE 
                *DEFAULT-READ-PRINT-PROFILE* FIND-READ-PRINT-PROFILE 
                LIST-ALL-READ-PRINT-PROFILE-NAMES)
       "XCL")

(DEFSTRUCT (READ-PRINT-PROFILE
 (:CONSTRUCTOR INTERNAL-MAKE-READ-PRINT-PROFILE))

(IL:* IL:;;; "Holds complete collection of read / print affecting globals.")


   READTABLE
   READ-BASE
   READ-SUPPRESS
   PACKAGE
   READ-DEFAULT-FLOAT-FORMAT
   PRINT-ESCAPE
   PRINT-PRETTY
   PRINT-CIRCLE
   PRINT-BASE
   PRINT-RADIX
   PRINT-CASE
   PRINT-GENSYM
   PRINT-LEVEL
   PRINT-LENGTH
   PRINT-ARRAY
   PRINT-STRUCTURE)

(DEFUN MAKE-READ-PRINT-PROFILE
 (&KEY (READTABLE *READTABLE*)
                                         (READ-BASE *READ-BASE*)
                                         (READ-SUPPRESS *READ-SUPPRESS*)
                                         (PACKAGE *PACKAGE*)
                                         (READ-DEFAULT-FLOAT-FORMAT *READ-DEFAULT-FLOAT-FORMAT*)
                                         (PRINT-ESCAPE *PRINT-ESCAPE*)
                                         (PRINT-PRETTY *PRINT-PRETTY*)
                                         (PRINT-CIRCLE *PRINT-CIRCLE*)
                                         (PRINT-BASE *PRINT-BASE*)
                                         (PRINT-RADIX *PRINT-RADIX*)
                                         (PRINT-CASE *PRINT-CASE*)
                                         (PRINT-GENSYM *PRINT-GENSYM*)
                                         (PRINT-LEVEL *PRINT-LEVEL*)
                                         (PRINT-LENGTH *PRINT-LENGTH*))

(IL:* IL:;;; "Create and return a profile with default contents the current bindings of the read print special variables.")


   (INTERNAL-MAKE-READ-PRINT-PROFILE :READTABLE READTABLE :READ-BASE READ-BASE :READ-SUPPRESS 
          READ-SUPPRESS :PACKAGE PACKAGE :READ-DEFAULT-FLOAT-FORMAT READ-DEFAULT-FLOAT-FORMAT 
          :PRINT-ESCAPE PRINT-ESCAPE :PRINT-PRETTY PRINT-PRETTY :PRINT-CIRCLE PRINT-CIRCLE 
          :PRINT-BASE PRINT-BASE :PRINT-RADIX PRINT-RADIX :PRINT-CASE PRINT-CASE :PRINT-GENSYM 
          PRINT-GENSYM :PRINT-LEVEL PRINT-LEVEL :PRINT-LENGTH PRINT-LENGTH))

(DEFUN RESTORE-READ-PRINT-PROFILE
 (PROFILE)
   "Restore values of special io bindings from profile.  Sets current bindings.  Returns T."
   (SETF *READTABLE* (READ-PRINT-PROFILE-READTABLE PROFILE))
   (SETF *READ-BASE* (READ-PRINT-PROFILE-READ-BASE PROFILE))
   (SETF *READ-SUPPRESS* (READ-PRINT-PROFILE-READ-SUPPRESS PROFILE))
   (SETF *PACKAGE* (READ-PRINT-PROFILE-PACKAGE PROFILE))
   (SETF *READ-DEFAULT-FLOAT-FORMAT* (READ-PRINT-PROFILE-READ-DEFAULT-FLOAT-FORMAT PROFILE))
   (SETF *PRINT-ESCAPE* (READ-PRINT-PROFILE-PRINT-ESCAPE PROFILE))
   (SETF *PRINT-PRETTY* (READ-PRINT-PROFILE-PRINT-PRETTY PROFILE))
   (SETF *PRINT-CIRCLE* (READ-PRINT-PROFILE-PRINT-CIRCLE PROFILE))
   (SETF *PRINT-BASE* (READ-PRINT-PROFILE-PRINT-BASE PROFILE))
   (SETF *PRINT-RADIX* (READ-PRINT-PROFILE-PRINT-RADIX PROFILE))
   (SETF *PRINT-CASE* (READ-PRINT-PROFILE-PRINT-CASE PROFILE))
   (SETF *PRINT-GENSYM* (READ-PRINT-PROFILE-PRINT-GENSYM PROFILE))
   (SETF *PRINT-LEVEL* (READ-PRINT-PROFILE-PRINT-LEVEL PROFILE))
   (SETF *PRINT-LENGTH* (READ-PRINT-PROFILE-PRINT-LENGTH PROFILE))
   (SETF *PRINT-ARRAY* (READ-PRINT-PROFILE-PRINT-ARRAY PROFILE))
   (SETF *PRINT-STRUCTURE* (READ-PRINT-PROFILE-PRINT-STRUCTURE PROFILE))
   T)

(DEFUN SAVE-READ-PRINT-PROFILE
 (PROFILE)
   "Capture bindings of special io variables.  Returns profile."
   (SETF (READ-PRINT-PROFILE-READTABLE PROFILE)
         *READTABLE*)
   (SETF (READ-PRINT-PROFILE-READ-BASE PROFILE)
         *READ-BASE*)
   (SETF (READ-PRINT-PROFILE-READ-SUPPRESS PROFILE)
         *READ-SUPPRESS*)
   (SETF (READ-PRINT-PROFILE-PACKAGE PROFILE)
         *PACKAGE*)
   (SETF (READ-PRINT-PROFILE-READ-DEFAULT-FLOAT-FORMAT PROFILE)
         *READ-DEFAULT-FLOAT-FORMAT*)
   (SETF (READ-PRINT-PROFILE-PRINT-ESCAPE PROFILE)
         *PRINT-ESCAPE*)
   (SETF (READ-PRINT-PROFILE-PRINT-PRETTY PROFILE)
         *PRINT-PRETTY*)
   (SETF (READ-PRINT-PROFILE-PRINT-CIRCLE PROFILE)
         *PRINT-CIRCLE*)
   (SETF (READ-PRINT-PROFILE-PRINT-BASE PROFILE)
         *PRINT-BASE*)
   (SETF (READ-PRINT-PROFILE-PRINT-RADIX PROFILE)
         *PRINT-RADIX*)
   (SETF (READ-PRINT-PROFILE-PRINT-CASE PROFILE)
         *PRINT-CASE*)
   (SETF (READ-PRINT-PROFILE-PRINT-GENSYM PROFILE)
         *PRINT-GENSYM*)
   (SETF (READ-PRINT-PROFILE-PRINT-LEVEL PROFILE)
         *PRINT-LEVEL*)
   (SETF (READ-PRINT-PROFILE-PRINT-LENGTH PROFILE)
         *PRINT-LENGTH*)
   (SETF (READ-PRINT-PROFILE-PRINT-ARRAY PROFILE)
         *PRINT-ARRAY*)
   (SETF (READ-PRINT-PROFILE-PRINT-STRUCTURE PROFILE)
         *PRINT-STRUCTURE*)
   PROFILE)

(DEFMACRO WITH-READ-PRINT-PROFILE
 (PROFILE-FORM &BODY FORMS)
   "Bind all the special IO variables to the values in the profile and execute the body forms."
   `(LET ((PROFILE ,PROFILE-FORM))
         (LET ((*READTABLE* (READ-PRINT-PROFILE-READTABLE PROFILE))
               (*READ-BASE* (READ-PRINT-PROFILE-READ-BASE PROFILE))
               (*READ-SUPPRESS* (READ-PRINT-PROFILE-READ-SUPPRESS PROFILE))
               (*PACKAGE* (READ-PRINT-PROFILE-PACKAGE PROFILE))
               (*READ-DEFAULT-FLOAT-FORMAT* (READ-PRINT-PROFILE-READ-DEFAULT-FLOAT-FORMAT PROFILE))
               (*PRINT-ESCAPE* (READ-PRINT-PROFILE-PRINT-ESCAPE PROFILE))
               (*PRINT-PRETTY* (READ-PRINT-PROFILE-PRINT-PRETTY PROFILE))
               (*PRINT-CIRCLE* (READ-PRINT-PROFILE-PRINT-CIRCLE PROFILE))
               (*PRINT-BASE* (READ-PRINT-PROFILE-PRINT-BASE PROFILE))
               (*PRINT-RADIX* (READ-PRINT-PROFILE-PRINT-RADIX PROFILE))
               (*PRINT-CASE* (READ-PRINT-PROFILE-PRINT-CASE PROFILE))
               (*PRINT-GENSYM* (READ-PRINT-PROFILE-PRINT-GENSYM PROFILE))
               (*PRINT-LEVEL* (READ-PRINT-PROFILE-PRINT-LEVEL PROFILE))
               (*PRINT-LENGTH* (READ-PRINT-PROFILE-PRINT-LENGTH PROFILE))
               (*PRINT-ARRAY* (READ-PRINT-PROFILE-PRINT-ARRAY PROFILE))
               (*PRINT-STRUCTURE* (READ-PRINT-PROFILE-PRINT-STRUCTURE PROFILE)))
              ,@FORMS)))

(DEFUN FIND-READ-PRINT-PROFILE
 (NAME)
   (GETHASH (STRING-UPCASE NAME)
          *READ-PRINT-PROFILES*))

(DEFUN SETF-FIND-READ-PRINT-PROFILE
 (NAME READ-PRINT-PROFILE)
   (CHECK-TYPE READ-PRINT-PROFILE READ-PRINT-PROFILE)
   (SETF (GETHASH (STRING-UPCASE NAME)
                *READ-PRINT-PROFILES*)
         READ-PRINT-PROFILE))

(DEFUN LIST-ALL-READ-PRINT-PROFILE-NAMES
 ()
   (LET ((NAMES NIL))
        (MAPHASH #'(LAMBDA (NAME VALUE)
                          (PUSH NAME NAMES))
               *READ-PRINT-PROFILES*)
        NAMES))

(DEFSETF FIND-READ-PRINT-PROFILE
 SETF-FIND-READ-PRINT-PROFILE)

(DEFPARAMETER *READ-PRINT-PROFILES*

   (LET ((TABLE (MAKE-HASH-TABLE :TEST 'EQUAL))
         (LISP-TABLE (MAKE-READ-PRINT-PROFILE :READTABLE (IL:FIND-READTABLE "LISP")
                            :READ-BASE 10 :READ-SUPPRESS NIL :PACKAGE (FIND-PACKAGE "USER")
                            :READ-DEFAULT-FLOAT-FORMAT
                            'SINGLE-FLOAT :PRINT-ESCAPE T :PRINT-PRETTY NIL :PRINT-CIRCLE NIL 
                            :PRINT-BASE 10 :PRINT-RADIX NIL :PRINT-CASE :UPCASE :PRINT-GENSYM T 
                            :PRINT-LEVEL NIL :PRINT-LENGTH NIL :PRINT-ARRAY NIL :PRINT-STRUCTURE NIL)
                )
         (XCL-TABLE (MAKE-READ-PRINT-PROFILE :READTABLE (IL:FIND-READTABLE "XCL")
                           :READ-BASE 10 :READ-SUPPRESS NIL :PACKAGE (FIND-PACKAGE "XCL-USER")
                           :READ-DEFAULT-FLOAT-FORMAT
                           'SINGLE-FLOAT :PRINT-ESCAPE T :PRINT-PRETTY NIL :PRINT-CIRCLE NIL 
                           :PRINT-BASE 10 :PRINT-RADIX NIL :PRINT-CASE :UPCASE :PRINT-GENSYM T 
                           :PRINT-LEVEL NIL :PRINT-LENGTH NIL :PRINT-ARRAY NIL :PRINT-STRUCTURE NIL))
         (INTERLISP-TABLE (MAKE-READ-PRINT-PROFILE :READTABLE (IL:FIND-READTABLE "INTERLISP")
                                 :READ-BASE 10 :READ-SUPPRESS NIL :PACKAGE (FIND-PACKAGE "INTERLISP")
                                 :READ-DEFAULT-FLOAT-FORMAT
                                 'SINGLE-FLOAT :PRINT-ESCAPE T :PRINT-PRETTY NIL :PRINT-CIRCLE NIL 
                                 :PRINT-BASE 10 :PRINT-RADIX NIL :PRINT-CASE :UPCASE :PRINT-GENSYM T
                                 :PRINT-LEVEL NIL :PRINT-LENGTH NIL :PRINT-ARRAY NIL :PRINT-STRUCTURE
                                 NIL)))
        (SETF (GETHASH "LISP" TABLE)
              LISP-TABLE)
        (SETF (GETHASH "XCL" TABLE)
              XCL-TABLE)
        (SETF (GETHASH "INTERLISP" TABLE)
              INTERLISP-TABLE)
        TABLE)
   "Where read-print-modes live.")

(DEFPARAMETER *DEFAULT-READ-PRINT-PROFILE*
 (FIND-READ-PRINT-PROFILE "INTERLISP")
                                               
                                 "The default read & print state to be used when not explicitly set.")

(IL:PUTPROPS IL:READ-PRINT-PROFILE
 IL:MAKEFILE-ENVIRONMENT
 (:READTABLE "INTERLISP" :PACKAGE 
                                                                          "XCL"))

(IL:PUTPROPS IL:READ-PRINT-PROFILE
 IL:FILETYPE
 IL:COMPILE-FILE)
(IL:PUTPROPS IL:READ-PRINT-PROFILE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1990))
(IL:DECLARE%: IL:DONTCOPY
  (IL:FILEMAP (NIL)))
IL:STOP