(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "XCL") (IL:FILECREATED "16-May-90 21:23:08" IL:{DSK}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}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