(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (|:DEFPACKAGE "XP" (USE "LISP") (SHADOW "CLEAR-OUTPUT" 
"FORCE-OUTPUT" "FINISH-OUTPUT" "DEFSTRUCT" "FRESH-LINE" "TERPRI" "WRITE-CHAR" "WRITE-STRING" 
"WRITE-LINE" "PRIN1-TO-STRING" "PRINC-TO-STRING" "WRITE-TO-STRING" "FORMAT" "PPRINT" "PRINC" "PRIN1" 
"PRINT" "WRITE") (IMPORT-FROM "COMMON-LISP" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" 
"*PRINT-RIGHT-MARGIN*" "*PRINT-PPRINT-DISPATCH*" "PPRINT-TAB" "PPRINT-INDENT" "PPRINT-NEWLINE" 
"PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" "PPRINT-LOGICAL-BLOCK" "PPRINT-TABULAR" "PPRINT-LINEAR" 
"PPRINT-FILL" "SET-PPRINT-DISPATCH" "PPRINT-DISPATCH" "COPY-PPRINT-DISPATCH" "FORMATTER") (EXPORT 
"*PRINT-SHARED*" "*LAST-ABBREVIATED-PRINTING*" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" 
"*DEFAULT-RIGHT-MARGIN*" "*PRINT-RIGHT-MARGIN*" "*PRINT-PPRINT-DISPATCH*" "PPRINT-TAB" "PPRINT-INDENT"
 "PPRINT-NEWLINE" "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" "PPRINT-LOGICAL-BLOCK" "PPRINT-TABULAR"
 "PPRINT-LINEAR" "PPRINT-FILL" "SET-PPRINT-DISPATCH" "PPRINT-DISPATCH" "COPY-PPRINT-DISPATCH" 
"FORMATTER")) BASE 10)
(IL:FILECREATED "12-Nov-93 15:21:42" ("compiled on " IL:|{DSK}<king>export>lispcore>sources>CLTL2>XP.;1|
) "11-Nov-93 16:58:33" IL:|bcompl'd| IL:|in| "Medley 11-Nov-93 ..." IL:|dated| "11-Nov-93 17:07:44")
(IL:FILECREATED " 4-Feb-93 15:08:51" IL:|{DSK}<usr>local>lde>lispcore>sources>XP.;12| 152559 
IL:|changes| IL:|to:| (IL:FUNCTIONS DEF-FORMAT-HANDLER BQ-PRINT BQ-COMMA-PRINT BQ-COMMA@-PRINT) (
INITIAL-DISPATCH (CONS (MEMBER IL:BQUOTE)) (CONS (MEMBER IL:\\\,)) (CONS (MEMBER IL:\\\,@))) (
FORMAT-HANDLERS #\/) (IL:VARS IL:XPCOMS) (IL:VARIABLES *FAST-FORMATTER-SLASH-CALL* 
*FORMATTER-SLASH-PARANOIA* *FORMATTER-SLASH-PARANOIA-LIST*) IL:|previous| IL:|date:| 
"10-Jul-92 11:51:54" IL:|{DSK}<usr>local>lde>lispcore>sources>XP.;10|)
(IL:PRETTYCOMPRINT IL:XPCOMS)
(IL:RPAQQ IL:XPCOMS ((IL:* IL:|;;| 
"------------------------------------------------------------------------ Copyright 1989,1990 by the Massachusetts Institute of Technology, Cambridge,  Massachusetts. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that this copyright and permission notice appear in all copies and supporting documentation, and that the name of M.I.T. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. M.I.T. makes no representations about the suitability of this software for any purpose.  It is provided \"as is\" without express or implied warranty.    M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING    ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL    M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,    WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,    ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS    SOFTWARE. ------------------------------------------------------------------------ This file \"XP.LISP\" implements an efficient pretty printer for Common Lisp.  The functions in this file are documented fully in MIT/AIM-1102a, July 1989.  This report can be obtained by sending $3.25 to              Publications 	       MIT AI Laboratory 	       545 Tech. Sq. 	       Cambridge MA 02139 This file attempts to be as compatible with pure Common Lisp as possible. It has been tested on the following Common Lisps to date (7/31/89).  Symbolics CL version 7 (does not work in version 6),  LUCID CL version 3.0.2 on a sun.  Allegro CL version 1.2.1 on a Macintosh.  CMU CL. The companion file \"XPTEST.LISP\" contains a set of 600+ tests.  You should run these tests after the first time you compile this file on a new system. The companion file \"XPDOC.TXT\" contains brief documentation."
) (IL:VARIABLES *XP-PRINTING-FUNCTIONS*) (IL:* IL:|;;| 
"must do the following in common lisps not supporting *print-shared*") (IL:VARIABLES *PRINT-SHARED*) (
IL:VARIABLES *PRINT-PPRINT-DISPATCH* *PRINT-RIGHT-MARGIN* *PRINT-MISER-WIDTH* *PRINT-LINES* 
*DEFAULT-RIGHT-MARGIN* *LAST-ABBREVIATED-PRINTING* *IPD* *CURRENT-LEVEL* *CURRENT-LENGTH* 
*ABBREVIATION-HAPPENED* *RESULT*) (IL:* IL:|;;| 
"default (bad) definitions for the non-portable functions") (IL:FUNCTIONS STRUCTURE-TYPE-P 
OUTPUT-WIDTH OUTPUT-POSITION) (IL:* IL:|;;| 
"XP is being considered for inclusion in Lucid Common Lisp. The prime contact there is Eric Benson \"eb@lucid.com\"."
) (IL:* IL:|;;| 
"XP is being included in CMU's Common Lisp. The prime contact there is Bill Chiles \"chiles@cs.cmu.edu\" and/or Blain Burks \"mbb@cs.cmu.edu\"."
) (IL:* IL:|;;| 
"Definitions for FRANZ Common Lisp. (Only verified for the version 1.3 (5/31/87) currently running on suns at MIT.)"
) (IL:* IL:|;;| 
"Joachim Laubsch <laubsch%hpljl@hplabs.hp.com> is the contact at HP Labs. He reports that HP COMMON LISP II Development Environment Rev A.02.15 11/10/88 requires the following patch due to a bug in REPLACE:"
) (IL:* IL:|;;| 
"JRB - Here is the Medley-specific code for XP.  There have also been a few #+ hacks inserted into things like WRITE+"
) (IL:VARIABLES *XP-STREAM-DEVICE*) (IL:FUNCTIONS XP-STREAM-OUTCHARFN XP-STREAM-DEVICE-CLOSEFILE) (
IL:FUNCTIONS INSTALL) (IL:VARIABLES *LOCATING-CIRCULARITIES* *PARENTS* *CIRCULARITY-HASH-TABLE*) (IL:*
 IL:|;;| 
"When an entry is first made it is zero. If a duplicate is found, a positive integer tag is assigned. After the first time the object is printed out, the tag is negated."
) (IL:VARIABLES *FREE-CIRCULARITY-HASH-TABLES*) (IL:* IL:\; "never bound") (IL:FUNCTIONS 
GET-CIRCULARITY-HASH-TABLE) (IL:* IL:|;;| 
"If you call this, then the table gets efficiently recycled.") (IL:FUNCTIONS 
FREE-CIRCULARITY-HASH-TABLE) (IL:* IL:|;;| "                      ---- DISPATCHING ----") (IL:STRUCTURES
 PPRINT-DISPATCH) (IL:* IL:|;;| 
"The list and the hash-tables contain entries of the following form.  When stored in the hash tables, the test entry is  the number of entries in the OTHERS list that have a higher priority."
) (IL:STRUCTURES ENTRY) (IL:* IL:\; "list of priority and type specifier") (IL:FUNCTIONS 
COPY-PPRINT-DISPATCH SET-PPRINT-DISPATCH SET-PPRINT-DISPATCH+ PRIORITY-> ADJUST-COUNTS PPRINT-DISPATCH
 GET-PRINTER FITS SPECIFIER-CATEGORY) (IL:VARIABLES *PREDS-FOR-SPECS*) (IL:FUNCTIONS ALWAYS-TRUE 
SPECIFIER-FN CONVERT-BODY) (IL:* IL:|;;| 
"              ---- XP STRUCTURES, AND THE INTERNAL ALGORITHM ----") (IL:* IL:\; 
"not used at run time.") (IL:VARIABLES BLOCK-STACK-ENTRY-SIZE PREFIX-STACK-ENTRY-SIZE QUEUE-ENTRY-SIZE
 BUFFER-ENTRY-SIZE PREFIX-ENTRY-SIZE SUFFIX-ENTRY-SIZE) (IL:* IL:\; "used at run time") (IL:VARIABLES 
BLOCK-STACK-MIN-SIZE PREFIX-STACK-MIN-SIZE QUEUE-MIN-SIZE BUFFER-MIN-SIZE PREFIX-MIN-SIZE 
SUFFIX-MIN-SIZE) (IL:* IL:|;;| 
"Hack of the month: The following definitions are used in Medley instead of the Common Lisp strcuture definition for XP-STRUCTURE; the idea is to make an XP-STRUCTURE look like a vanilla STREAM object to as much of the system as possible; most of its funny functionality will be buried in stream functions"
) (IL:* IL:|;;| 
"We need a way to conditionalize file manager entries; I'll look into it sometime soon...") (IL:* 
IL:|;;| "Here is the DEFSTRUCT we are simulating :") (IL:* IL:|;;| "(CL:DEFSTRUCT") (IL:* IL:|;;| 
"(XP::XP-STRUCTURE (:CONC-NAME NIL) (:PRINT-FUNCTION XP::DESCRIBE-XP) #+INTERLISP (:FAST-ACCESSORS T))"
) (IL:* IL:|;;| 
"(XP::BASE-STREAM NIL) ; The stream io eventually goes to. XP::LINEL ; The line length to use for formatting."
) (IL:* IL:|;;| "XP::LINE-LIMIT ; If non-NIL the max number of lines to ; print.") (IL:* IL:|;;| 
"XP::LINE-NO ; number of next line to be printed.") (IL:* IL:|;;| 
"XP::CHAR-MODE ; NIL :UP :DOWN :CAP0 :CAP1 :CAPW XP::CHAR-MODE-COUNTER ; depth of nesting of ~(...~)")
 (IL:* IL:|;;| 
"XP::DEPTH-IN-BLOCKS ; Number of logical blocks at QRIGHT ; that are started but not ended.") (IL:* 
IL:|;;| 
"(XP::BLOCK-STACK (CL:MAKE-ARRAY #.XP::BLOCK-STACK-MIN-SIZE)) XP::BLOCK-STACK-PTR ;; This stack is pushed and popped in accordance with the way blocks are  nested at the moment ;; they are entered into the queue.  It contains the  following block specific value. ;; SECTION-START total position where the section (see AIM-1102) that is rightmost in the queue ;; started."
) (IL:* IL:|;;| 
"(XP::BUFFER (CL:MAKE-ARRAY #.XP::BUFFER-MIN-SIZE :ELEMENT-TYPE #-SYMBOLICS (QUOTE LISP:STRING-CHAR) #+SYMBOLICS 'character)) XP::CHARPOS"
) (IL:* IL:|;;| "XP::BUFFER-PTR") (IL:* IL:|;;| 
"XP::BUFFER-OFFSET ;; This is a vector of characters (eg a string) that builds up the line images that will be ;; printed out.  BUFFER-PTR is the buffer position where the next character should be inserted in ;; the string.  CHARPOS is the output character position of the first character in the buffer ;; (non-zero only if a partial line has been output).  BUFFER-OFFSET is used in computing total ;; lengths. It is changed to reflect all shifting and insertion of prefixes so that total length ;; computes things as they would be if they were  all on one line.  Positions are kept three ;; different ways Buffer position (eg BUFFER-PTR) Line position (eg (+ BUFFER-PTR CHARPOS)).  ;; Indentations are stored in this form. Total position if all on one line (eg (+ BUFFER-PTR ;; BUFFER-OFFSET))  Positions are stored in this form."
) (IL:* IL:|;;| 
"(XP::QUEUE (CL:MAKE-ARRAY #.XP::QUEUE-MIN-SIZE)) XP::QLEFT XP::QRIGHT ;; This holds a queue of action descriptors.  QLEFT and QRIGHT point to the next entry to dequeue ;; and the last entry enqueued respectively.  The queue is empty when (> QLEFT QRIGHT).  The ;; queue entries have several parts: QTYPE one of :NEWLINE/:IND/:START-BLOCK/:END-BLOCK QKIND ;; :LINEAR/:MISER/:FILL/:MANDATORY or :UNCONDITIONAL/:FRESH or :BLOCK/:CURRENT QPOS total ;; position corresponding to this entry QDEPTH depth in blocks of this entry. QEND offset to ;; entry marking end of section this entry starts. (NIL until known.) Only :start-block and ;; non-literal :newline entries can start sections. QOFFSET offset to :END-BLOCK for :START-BLOCK ;; (NIL until known). QARG for :IND indentation delta     for :START-BLOCK suffix in the block if ;; any.                      or if per-line-prefix then cons of suffix and                      ;; per-line-prefix.     for :END-BLOCK suffix for the block if any."
) (IL:* IL:|;;| 
"(XP::PREFIX (CL:MAKE-ARRAY #.XP::BUFFER-MIN-SIZE :ELEMENT-TYPE #-SYMBOLICS (QUOTE LISP:STRING-CHAR) #+SYMBOLICS 'character)) ;; this stores the prefix that should be used at the start of the line"
) (IL:* IL:|;;| "(XP::PREFIX-STACK (CL:MAKE-ARRAY #.XP::PREFIX-STACK-MIN-SIZE))") (IL:* IL:|;;| 
"XP::PREFIX-STACK-PTR ;; This stack is pushed and popped in accordance with the way blocks  are nested at the moment ;; things are taken off the queue and printed. It contains the following block specific values. ;; PREFIX-PTR current length of PREFIX. SUFFIX-PTR current length of pending suffix ;; NON-BLANK-PREFIX-PTR current length of non-blank prefix. INITIAL-PREFIX-PTR prefix-ptr at the ;; start of this block. SECTION-START-LINE line-no value at last non-literal break at this level."
) (IL:* IL:|;;| 
"(XP::SUFFIX (CL:MAKE-ARRAY #.XP::BUFFER-MIN-SIZE :ELEMENT-TYPE #-SYMBOLICS (QUOTE LISP:STRING-CHAR) #+SYMBOLICS 'character)))"
) (IL:RECORDS XP-STRUCTURE) (IL:FUNCTIONS BASE-STREAM LINEL LINE-LIMIT LINE-NO CHAR-MODE 
CHAR-MODE-COUNTER DEPTH-IN-BLOCKS BLOCK-STACK BLOCK-STACK-PTR BUFFER CHARPOS BUFFER-PTR BUFFER-OFFSET 
QUEUE QLEFT QRIGHT PREFIX PREFIX-STACK PREFIX-STACK-PTR SUFFIX MAKE-XP-STRUCTURE XP-STRUCTURE-P) (IL:*
 IL:|;;| 
"this stores the suffixes that have to be printed to close of the current open blocks.  For convenient in popping, the whole suffix is stored in reverse order."
) (IL:FUNCTIONS LP<-BP TP<-BP BP<-LP BP<-TP) (IL:* IL:|;;| 
"This does not tell you the line position you were at when the TP was set, unless there have been no newlines or indentation output  between ptr and the current output point."
) (IL:FUNCTIONS LP<-TP) (IL:* IL:|;;| 
"We don't use adjustable vectors or any of that, because we seldom have to actually extend and non-adjustable vectors are a lot faster in many Common Lisps."
) (IL:FUNCTIONS CHECK-SIZE SECTION-START PUSH-BLOCK-STACK POP-BLOCK-STACK PREFIX-PTR SUFFIX-PTR 
NON-BLANK-PREFIX-PTR INITIAL-PREFIX-PTR SECTION-START-LINE PUSH-PREFIX-STACK POP-PREFIX-STACK QTYPE 
QKIND QPOS QDEPTH QEND QOFFSET QARG) (IL:* IL:|;;| 
"we shift the queue over rather than using a circular queue because that works out to be a lot faster in practice.  Note, short printout does not ever cause a shift, and even in long printout, the queue is shifted left for free every time it happens to empty out."
) (IL:FUNCTIONS ENQUEUE QNEXT) (IL:VARIABLES *DESCRIBE-XP-STREAMS-FULLY*) (IL:FUNCTIONS DESCRIBE-XP) (
IL:* IL:|;;| 
"This maintains a list of XP structures.  We save them so that we don't have to create new ones all of the time. We have separate objects so that many can be in use at once. (Note should really be doing some locking here, but CL does not have the primitives for it.  There is a tiny probability here that two different processes could end up trying to use the same xp-stream)"
) (IL:VARIABLES *FREE-XPS*) (IL:* IL:\; "never bound") (IL:FUNCTIONS GET-PRETTY-PRINT-STREAM) (IL:* 
IL:|;;| "If you call this, the xp-stream gets efficiently recycled.") (IL:FUNCTIONS 
FREE-PRETTY-PRINT-STREAM) (IL:* IL:|;;| 
"This is called to initialize things when you start pretty printing.") (IL:FUNCTIONS INITIALIZE-XP) (
IL:* IL:|;;| 
"The char-mode stuff is a bit tricky. one can be in one of the following modes: NIL no changes to characters output. :UP CHAR-UPCASE used. :DOWN CHAR-DOWNCASE used. :CAP0 capitalize next alphanumeric letter then switch to :DOWN. :CAP1 capitalize next alphanumeric letter then switch to :CAPW :CAPW downcase letters.  When a word break letter found, switch to :CAP1. It is possible for ~(~) to be nested in a format string, but note that each mode specifies what should happen to every letter.  Therefore, inner nested modes never have any effect.  You can just ignore them."
) (IL:FUNCTIONS PUSH-CHAR-MODE POP-CHAR-MODE HANDLE-CHAR-MODE) (IL:* IL:|;;| 
":DOWN All characters output are passed through the handler above.  However, it must be noted that on-each-line prefixes are only processed in the context of the first place they appear.  They stay the same later no matter what.  Also non-literal newlines do not count as word breaks. This handles the basic outputting of characters.  note + suffix means that the stream is known to be an XP stream, all inputs are mandatory, and no error checking has to be done.  Suffix ++ additionally means that the output is guaranteed not to contain a newline char."
) (IL:FUNCTIONS WRITE-CHAR+ WRITE-STRING+) (IL:* IL:|;;| 
"note this checks (> BUFFER-PTR LINEL) instead of (> (LP<-BP) LINEL) this is important so that when things are longer than a line they end up getting printed in chunks of size LINEL."
) (IL:FUNCTIONS WRITE-CHAR++ FORCE-SOME-OUTPUT WRITE-STRING++) (IL:* IL:|;;| 
"never forces output; therefore safe to call from within output-line.") (IL:FUNCTIONS WRITE-STRING+++ 
PPRINT-TAB+) (IL:* IL:|;;| 
"note following is smallest number >= x that is a multiple of colinc  (* colinc (floor (+ x (1- colinc)) colinc))"
) (IL:FUNCTIONS PPRINT-NEWLINE+ START-BLOCK END-BLOCK PPRINT-INDENT+) (IL:* IL:|;;| 
"The next function scans the queue looking for things it can do. it keeps outputting things until the queue is empty, or it finds a place where it cannot make a decision yet."
) (IL:FUNCTIONS MAYBE-TOO-LARGE) (IL:* IL:\; "wait until later to decide.") (IL:FUNCTIONS MISERING?) (
IL:* IL:|;;| 
"If flush-out? is T and force-newlines? is NIL then the buffer, prefix-stack, and queue will be in an inconsistent state after the call. You better not call it this way except as the last act of outputting."
) (IL:FUNCTIONS ATTEMPT-TO-OUTPUT) (IL:* IL:\; "this can only be called last!") (IL:FUNCTIONS FLUSH) (
IL:* IL:\; "This prints out a line of stuff.") (IL:FUNCTIONS OUTPUT-LINE SETUP-FOR-NEXT-LINE 
SET-INDENTATION-PREFIX SET-PREFIX SET-SUFFIX REVERSE-STRING-IN-PLACE) (IL:* IL:|;;| 
"		   ---- BASIC INTERFACE FUNCTIONS ---- The internal functions in this file, and the (formatter \"...\") expansions use the '+' forms of these functions directly (which is faster) because, they do not need error checking of fancy stream coercion.  The '++' forms additionally assume the thing being output does not contain a newline."
) (IL:FUNCTIONS WRITE BASIC-WRITE MAYBE-INITIATE-XP-PRINTING) (IL:FUNCTIONS XP-PRINT) (IL:FUNCTIONS 
DECODE-STREAM-ARG DO-XP-PRINTING WRITE+ NON-PRETTY-PRINT) (IL:* IL:|;;| 
"It is vital that this function be called EXACTLY once for each occurrence of   each thing in something being printed. Returns nil if printing should just continue on.  Either it is not a duplicate, or we are in the first pass and do not know. returns :FIRST if object is first occurrence of a DUPLICATE.  (This can only be returned on a second pass.)  After an initial code (printed by this routine on the second pass)  printing should continue on for the object. returns :SUBSEQUENT if second or later occurrence.  Printing is all taken care of by this routine. Note many (maybe most) lisp implementations have characters and small numbers represented in a single word so that the are always eq when they are equal and the reader takes care of properly sharing them (just as it does with symbols). Therefore, we do not want circularity processing applied to them.  However, some kinds of numbers (e.g., bignums) undoubtedly are complex structures that the reader does not share.  However, they cannot have circular pointers in them and it is therefore probably a waste to do circularity checking on them.  In any case, it is not clear that it easy to tell exactly what kinds of numbers a given implementation of CL is going to have the reader automatically share."
) (IL:FUNCTIONS CIRCULARITY-PROCESS) (IL:* IL:|;;| 
"This prints a few very common, simple atoms very fast. Pragmatically, this turns out to be an enormous savings over going to the standard printer all the time.  There would be diminishing returns from making this work with more things, but might be worth it."
) (IL:FUNCTIONS MAYBE-PRINT-FAST PRINT-FIXNUM) (IL:* IL:|;;| 
"just wants to succeed fast in a lot of common cases. assumes no funny readtable junk for the characters shown."
) (IL:FUNCTIONS NO-ESCAPES-NEEDED PRINT PRIN1 PRINC PPRINT WRITE-TO-STRING PRINC-TO-STRING 
PRIN1-TO-STRING) (IL:* IL:|;;| 
"Any format string that is converted to a function is always printed via an XP stream (See formatter)."
) (IL:FUNCTIONS FORMAT) (IL:VARIABLES *FORMAT-STRING-CACHE*) (IL:FUNCTIONS PROCESS-FORMAT-STRING 
WRITE-LINE WRITE-STRING WRITE-CHAR TERPRI) (IL:* IL:|;;| 
"This has to violate the XP data abstraction and fool with internal stuff, in order to find out the right info to return as the result."
) (IL:FUNCTIONS FRESH-LINE) (IL:* IL:|;;| 
"Each of these causes the stream to be pessimistic and insert newlines wherever it might have to, when forcing the partial output out.  This is so that things will be in a consistent state if output continues to the stream later."
) (IL:FUNCTIONS FINISH-OUTPUT FORCE-OUTPUT CLEAR-OUTPUT) (IL:* IL:|;;| 
"note we are assuming that if a structure is defined using xp::defstruct, then its print-function (if any) will be defined using xp::print etc."
) (IL:FUNCTIONS DEFSTRUCT SAFE-ASSOC) (IL:* IL:|;;| 
"A few helper functions.  Calls to these are generated by SET-XP-PRINTER, which handles default pretty-printing of structures"
) (IL:FUNCTIONS CL::STRUCTURE-WITH-USER-PRINTER CL::STRUCTURE-WITH-DEFAULT-PRINTER) (IL:* IL:|;;| 
"          ---- FUNCTIONAL INTERFACE TO DYNAMIC FORMATTING ---- The internal functions in this file, and the (formatter \"...\") expansions use the '+' forms of these functions directly (which is faster) because, they do not need error checking or fancy stream coercion.  The '++' forms additionally assume the thing being output does not contain a newline."
) (IL:FUNCTIONS PPRINT-LOGICAL-BLOCK) (IL:* IL:|;;| 
"Assumes var and args must be variables.  Other arguments must be literals or variables.") (IL:FUNCTIONS
 PPRINT-LOGICAL-BLOCK+ PPRINT-NEWLINE PPRINT-INDENT PPRINT-TAB) (IL:* IL:|;;| 
"                       ---- COMPILED FORMAT ---- Note that compiled format strings always print through xp streams even if they don't have any xp directives in them.  As a result, the compiled code can depend on the fact that the stream being operated on is an xp stream not an ordinary one."
) (IL:P (PROCLAIM (QUOTE (SPECIAL *STRING* *USED-ARGS* *USED-OUTER-ARGS* *USED-INITIAL* 
*GET-ARG-CAREFULLY* *INNER-END* *OUTER-END* *AT-TOP* *DEFAULT-PACKAGE*)))) (IL:VARIABLES *FN-TABLE*) (
IL:* IL:|;;| 
"Each of these functions expect to get called with two arguments start and end.  Start points to the first character after the ~ marking the command.  End points to the first character after the command.  This includes the matching end command for paired commands."
) (IL:DEFINE-TYPES FORMAT-HANDLERS) (IL:FUNCTIONS DEF-FORMAT-HANDLER FORMAT-HANDLER-UNDEFINE) (IL:* 
IL:|;;| 
"Definitions of the forms used in the code created by PARSE. Note these functions assume the stream is in the var XP and is an xp stream, INITIAL holds the initial value of ARGS (for ~@*). Initial is always bound to (args) if it is bound at all. Note this uses args, but only when actually binding"
) (IL:FUNCTIONS INITIAL BIND-INITIAL MAYBE-BIND-INITIAL) (IL:* IL:|;;| 
"ARGS holds the current argument list The val bound to args must always be computed (to use it up) even if args is not used."
) (IL:FUNCTIONS ARGS BIND-ARGS OUTER-ARGS BIND-OUTER-ARGS MAYBE-BIND MAKE-BINDING NUM-ARGS GET-ARG 
PPRINT-POP+ PPRINT-POP-CHECK+ PPRINT-POP+TOP PPRINT-POP-CHECK+TOP LITERAL) (IL:* IL:\; 
"This is available for putting on #\".") (IL:FUNCTIONS FORMAT-STRING-READER FORMATTER-IN-PACKAGE 
FORMATTER FORMATTER-FN) (IL:* IL:|;;| 
"The business with the catch above allows many (formatter \"...\") errors to be reported in a file without stopping the compilation of the file."
) (IL:FUNCTIONS MAYBE-COMPILE-FORMAT-STRING) (IL:* IL:|;;| 
"COMPILE-FORMAT gets called to turn a bit of format control string into code.") (IL:VARIABLES 
*TESTING-ERRORS*) (IL:FUNCTIONS ERR POSITION-IN POSITION-NOT-IN NEXT-DIRECTIVE1 PARAMS-END) (IL:* 
IL:|;;| "Only called after correct parse is known.") (IL:FUNCTIONS DIRECTIVE-START NEXT-DIRECTIVE) (IL:*
 IL:\; "breaks things up at ~; directives.") (IL:FUNCTIONS CHUNK-UP FANCY-DIRECTIVES-P 
NUM-ARGS-IN-ARGS COMPILE-FORMAT) (IL:* IL:|;;| 
"This gets called with start pointing to the character after the ~ that starts a command.  Defaults, is a list of default values for the parameters.  Max is the maximum number of parameters allowed.  Nocolon, noatsign, nocolonatsign can be used to specify what colon atsign combinations are permitted. Parse params returns three values, colon?, atsign? and a list of code chunks that correspond to the parameters specified."
) (IL:FUNCTIONS PARSE-PARAMS) (IL:* IL:|;;| "Both these only called if correct parse already known.") 
(IL:FUNCTIONS COLONP ATSIGNP) (IL:* IL:|;;| 
"These flags and lists control some non-spec behavior in FORMATTER's handling of the ~/.../ directive"
) (IL:VARIABLES *FAST-FORMATTER-SLASH-CALL* *FORMATTER-SLASH-PARANOIA* *FORMATTER-SLASH-PARANOIA-LIST*
) (FORMAT-HANDLERS #\/ #\A #\S) (IL:* IL:|;;| 
"The basic Format directives \"DBOXRCFEG$\".  The key thing about all of these directives is that they just get a single arg and print a chunk of stuff.  Further they are complex enough that I just call the standard definition of FORMAT to get the work done.  What should really be being called is the internal routine that FORMAT uses to do the corresponding work.  However, this cannot be done in a portable way."
) (FORMAT-HANDLERS #\D #\B #\O #\X #\R #\C #\F #\E #\G #\$) (IL:FUNCTIONS SIMPLE-DIRECTIVE 
USING-FORMAT) (IL:* IL:|;;| "Format directives that get open coded \"P%&~|T*?^\"") (FORMAT-HANDLERS 
#\P #\% #\&) (IL:FUNCTIONS MULTIPLE-NEWLINES MULTIPLE-NEWLINES1) (FORMAT-HANDLERS #\| #\~) (IL:FUNCTIONS
 MULTIPLE-CHARS MULTIPLE-CHARS1) (FORMAT-HANDLERS #\T #\*) (IL:* IL:|;;| 
"fancy stuff here, so will not get spurious indications of circularity.") (IL:FUNCTIONS BACKUP-IN-LIST
 BACKUP-TO) (IL:* IL:|;;| 
"because of backup-to, a prefix of some-tail may have been copied (in which case it cannot share anything with list), but there is a cons in some-tail that is in list.  This can be used to determine the position of some-tail relative to list.  However, we have to be careful, because they both could be cdr recursive."
) (IL:FUNCTIONS TAIL-POS) (FORMAT-HANDLERS #\? #\^) (IL:FUNCTIONS DO-COMPLEX-^-TEST) (IL:* IL:|;;| 
"delimited pairs of format directives. \"(){}[]<>;\"") (FORMAT-HANDLERS #\[ #\( #\; #\] #\) #\> #\} 
#\{ #\<) (IL:FUNCTIONS HANDLE-STANDARD-< NUM-ARGS-IN-DIRECTIVE) (IL:* IL:\; 
"The pretty-printing directives. \"_IW<:>\"") (FORMAT-HANDLERS #\_ #\I #\W) (IL:FUNCTIONS 
HANDLE-LOGICAL-BLOCK CHECK-BLOCK-ABBREVIATION FILL-TRANSFORM FILL-TRANSFORM-CHAR 
FILL-TRANSFORM-LITERAL) (IL:* IL:|;;| 
"end of eval when for all (formatter \"...\") stuff.                ---- PRETTY PRINTING FORMATS ----"
) (IL:FUNCTIONS PRETTY-ARRAY PRETTY-VECTOR PRETTY-NON-VECTOR) (IL:* IL:|;;| 
"Must use pprint-logical-block (no +) in the following three, because they are exported functions.") (
IL:FUNCTIONS PPRINT-LINEAR PPRINT-FILL PPRINT-TABULAR FN-CALL) (IL:* IL:|;;| 
"Although idiosyncratic, I have found this very useful to avoid large indentations when printing out code."
) (IL:FUNCTIONS ALTERNATIVE-FN-CALL BIND-LIST BLOCK-LIKE DEFUN-LIKE PRINT-FANCY-FN-CALL MAYBELAB 
FUNCTION-CALL-P) (IL:* IL:|;;| 
"THE FOLLOWING STUFF SETS UP THE DEFAULT *PRINT-PPRINT-DISPATCH* This is an attempt to specify a correct format for every form in the CL book that does not just get printed out like an ordinary function call  (i.e., most special forms and many macros).  This of course does not  cover anything new you define."
) (IL:FUNCTIONS LET-PRINT COND-PRINT DMM-PRINT DEFSETF-PRINT DO-PRINT FLET-PRINT FUNCTION-PRINT 
MVB-PRINT PROG-PRINT SETQ-PRINT QUOTE-PRINT TAGBODY-PRINT UP-PRINT) (IL:* IL:|;;| 
"here is some simple stuff for printing LOOP The challange here is that we have to effectively parse the clauses of the loop in order to know how to print things.  Also you want to do this in a  purely incremental way so that all of the abbreviation things work, and you wont blow up on circular lists or the like.  (More aesthic output could be produced by really parsing the clauses into nested lists before printing them.) The following program assumes the following simplified grammar of the loop clauses that explains how to print them.  Note that it does not bare much resemblence to the right parsing grammar, however, it produces half decent output.  The way to make the output better is to make the grammar more detailed.    loop == (LOOP {clause}*)      ;one clause on each line. clause == block | linear | cond | finally block == block-head {expr}*   ;as many exprs as possible on each line. linear == linear-head {expr}* ;one expr on each line. finally == FINALLY [DO | DOING | RETURN] {expr}* ;one expr on each line. cond == cond-head [expr]          clause 	   {AND clause}*       ;one AND on each line.        [ELSE          clause 	   {AND clause}*]      ;one AND on each line.        [END] block-head == FOR | AS | WITH | AND              | REPEAT | NAMED | WHILE | UNTIL | ALWAYS | NEVER | THEREIS | RETURN              | COLLECT | COLLECTING | APPEND | APPENDING | NCONC | NCONCING | COUNT              | COUNTING | SUM | SUMMING | MAXIMIZE | MAXIMIZING | MINIMIZE | MINIMIZING  linear-head == DO | DOING | INITIALLY var-head == FOR | AS | WITH cond-head == IF | WHEN | UNLESS expr == <anything that is not a head symbol> Note all the string comparisons below are required to support some existing implementations of LOOP."
) (IL:FUNCTIONS TOKEN-TYPE PRETTY-LOOP) (IL:* IL:|;;| 
"Backquote-printing is easy for us, since the read macros just expand into simple wrappers.") (
IL:FUNCTIONS BQ-PRINT BQ-COMMA-PRINT BQ-COMMA@-PRINT) (IL:* IL:|;;| 
"This method of handling Interlisp comments sucks, BUT there is no way under XP to temporarily ignore an existing per-line-prefix, which is what you would have to do to get ;;; and ;;;; comments to go to the left margin.  Phooey!"
) (IL:FUNCTIONS IL-COMMENT) (IL:P (SETQ *IPD* (MAKE-PPRINT-DISPATCH))) (IL:DEFINE-TYPES 
INITIAL-DISPATCH) (IL:FUNCTIONS SET-PPD-IPD) (INITIAL-DISPATCH (SATISFIES FUNCTION-CALL-P) CONS) (
INITIAL-DISPATCH (CONS (MEMBER DEFSTRUCT)) (CONS (MEMBER BLOCK)) (CONS (MEMBER CASE)) (CONS (MEMBER 
CATCH)) (CONS (MEMBER CCASE)) (CONS (MEMBER COMPILER-LET)) (CONS (MEMBER COND)) (CONS (MEMBER 
CTYPECASE)) (CONS (MEMBER DEFCONSTANT)) (CONS (MEMBER DEFINE-SETF-METHOD)) (CONS (MEMBER DEFMACRO)) (
CONS (MEMBER DEFINE-MODIFY-MACRO)) (CONS (MEMBER DEFPARAMETER)) (CONS (MEMBER DEFSETF)) (CONS (MEMBER 
DEFINE-SETF-METHOD)) (CONS (MEMBER CL:DEFSTRUCT)) (CONS (MEMBER DEFTYPE)) (CONS (MEMBER DEFUN)) (CONS 
(MEMBER DEFVAR)) (CONS (MEMBER DO)) (CONS (MEMBER DO*)) (CONS (MEMBER DO-ALL-SYMBOLS)) (CONS (MEMBER 
DO-EXTERNAL-SYMBOLS)) (CONS (MEMBER DO-SYMBOLS)) (CONS (MEMBER DOLIST)) (CONS (MEMBER DOTIMES)) (CONS 
(MEMBER ECASE)) (CONS (MEMBER ETYPECASE)) (CONS (MEMBER EVAL-WHEN)) (CONS (MEMBER FLET)) (CONS (MEMBER
 FUNCTION)) (CONS (MEMBER LABELS)) (CONS (MEMBER LAMBDA)) (CONS (MEMBER LET)) (CONS (MEMBER LET*)) (
CONS (MEMBER LOCALLY)) (CONS (MEMBER LOOP)) (CONS (MEMBER MACROLET)) (CONS (MEMBER MULTIPLE-VALUE-BIND
)) (CONS (MEMBER MULTIPLE-VALUE-SETQ)) (CONS (MEMBER PROG)) (CONS (MEMBER PROG*)) (CONS (MEMBER PROGV)
) (CONS (MEMBER PSETF)) (CONS (MEMBER PSETQ)) (CONS (MEMBER QUOTE)) (CONS (MEMBER RETURN-FROM)) (CONS 
(MEMBER SETF)) (CONS (MEMBER SETQ)) (CONS (MEMBER TAGBODY)) (CONS (MEMBER THROW)) (CONS (MEMBER 
TYPECASE)) (CONS (MEMBER UNLESS)) (CONS (MEMBER UNWIND-PROTECT)) (CONS (MEMBER WHEN)) (CONS (MEMBER 
WITH-INPUT-FROM-STRING)) (CONS (MEMBER WITH-OPEN-FILE)) (CONS (MEMBER WITH-OPEN-STREAM)) (CONS (MEMBER
 WITH-OUTPUT-TO-STRING))) (IL:* IL:|;;| 
"Interlisp-specific entries in the original table; we need a bunch more of these, and a MUCH better way to print Interlisp comments"
) (INITIAL-DISPATCH (CONS (MEMBER IL:*)) (CONS (MEMBER IL:BQUOTE)) (CONS (MEMBER IL:\\\,)) (CONS (
MEMBER IL:\\\,@))) (IL:FUNCTIONS PPRINT-DISPATCH-PRINT) (IL:P (SETF (GET (QUOTE PPRINT-DISPATCH) (
QUOTE CL::STRUCTURE-PRINTER)) (FUNCTION PPRINT-DISPATCH-PRINT))) (INITIAL-DISPATCH PPRINT-DISPATCH) (
IL:* IL:\; "so only happens first time is loaded.") (IL:P (WHEN (EQ *PRINT-PPRINT-DISPATCH* T) (SETQ 
*PRINT-PPRINT-DISPATCH* (COPY-PPRINT-DISPATCH IL:NIL)))) (IL:* IL:|;;| 
"changes since last documentation. ~/fn/ only refers to global function values, not lexical. ------------------------------------------------------------------------ Copyright 1989,1990 by the Massachusetts Institute of Technology, Cambridge,  Massachusetts. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that this copyright and permission notice appear in all copies and supporting documentation, and that the name of M.I.T. not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. M.I.T. makes no representations about the suitability of this software for any purpose.  It is provided \"as is\" without express or implied warranty.    M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING    ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL    M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,    WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,    ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS    SOFTWARE. ------------------------------------------------------------------------"
) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:XP)))
(DEFVAR *XP-PRINTING-FUNCTIONS* (QUOTE (WRITE PRINT PRIN1 PRINC PPRINT FORMAT WRITE-TO-STRING 
PRINC-TO-STRING PRIN1-TO-STRING WRITE-LINE WRITE-STRING WRITE-CHAR TERPRI FRESH-LINE DEFSTRUCT 
FINISH-OUTPUT FORCE-OUTPUT CLEAR-OUTPUT)) "printing functions redefined by xp.")
(DEFVAR *PRINT-SHARED* IL:NIL)
(DEFVAR *PRINT-PPRINT-DISPATCH* T (IL:* IL:\; "see initialization at end of file.") 
"controls pretty printing of output")
(DEFVAR *PRINT-RIGHT-MARGIN* IL:NIL "+#/nil the right margin for pretty printing")
(DEFVAR *PRINT-MISER-WIDTH* 40 "+#/nil miser format starts when there is less than this width left")
(DEFVAR *PRINT-LINES* IL:NIL "+#/nil truncates printing after # lines")
(DEFVAR *DEFAULT-RIGHT-MARGIN* 70 "controls default line length; must be a non-negative integer")
(DEFVAR *LAST-ABBREVIATED-PRINTING* (FUNCTION (LAMBDA (&OPTIONAL STREAM) (DECLARE (IGNORE STREAM)) 
IL:NIL)) "funcalling this redoes the last xp printing that was abbreviated.")
(DEFVAR *IPD* IL:NIL (IL:* IL:\; "see initialization at end of file.") "initial print dispatch table."
)
(DEFVAR *CURRENT-LEVEL* 0 "current depth in logical blocks.")
(DEFVAR *CURRENT-LENGTH* 0 "current position in logical block.")
(DEFVAR *ABBREVIATION-HAPPENED* IL:NIL "t if current thing being printed has been abbreviated.")
(DEFVAR *RESULT* IL:NIL "used to pass back a value")
(DEFUN STRUCTURE-TYPE-P (X) (IL:* IL:|;;| "(AND (SYMBOLP X) (GET X 'STRUCTURE-PRINTER))") (
CL::PARSED-STRUCTURE X T))
(DEFUN OUTPUT-WIDTH (&OPTIONAL (S *STANDARD-OUTPUT*)) (IL:LINELENGTH IL:NIL S))
(DEFUN OUTPUT-POSITION (&OPTIONAL (S *STANDARD-OUTPUT*)) (IL:* IL:\; "Edited  6-May-92 12:37 by jrb:")
 (IL:POSITION S))
(DEFVAR *XP-STREAM-DEVICE* (IL:* IL:|;;| 
"A first hack at integrating XP into Medley.  A stream with this as its fdev lives in the MEDLEY-STREAM slot of an XP-STRUCTURE.  Whenever XP punts in WRITE+, it just does its output to its MEDLEY-STREAM, which catches each character and calls WRITE-CHAR++; this is actually reasonably fast."
) (IL:|create| IL:FDEV IL:DEVICENAME IL:_ (QUOTE *XP-STREAM-DEVICE*) IL:RESETABLE IL:_ IL:NIL 
IL:RANDOMACCESSP IL:_ IL:NIL IL:NODIRECTORIES IL:_ T IL:BUFFERED IL:_ IL:NIL IL:PAGEMAPPED IL:_ IL:NIL
 IL:FDBINABLE IL:_ IL:NIL IL:FDBOUTABLE IL:_ IL:NIL IL:FDEXTENDABLE IL:_ IL:NIL IL:DEVICEINFO IL:_ 
IL:NIL IL:HOSTNAMEP IL:_ (IL:FUNCTION IL:NILL) IL:EVENTFN IL:_ (IL:FUNCTION IL:NILL) IL:DIRECTORYNAMEP
 IL:_ (IL:FUNCTION IL:NILL) IL:OPENFILE IL:_ (IL:FUNCTION IL:NILL) IL:REOPENFILE IL:_ (IL:FUNCTION 
IL:NILL) IL:CLOSEFILE IL:_ (IL:FUNCTION XP-STREAM-DEVICE-CLOSEFILE) IL:GETFILENAME IL:_ (IL:FUNCTION 
IL:NILL) IL:DELETEFILE IL:_ (IL:FUNCTION IL:NILL) IL:GENERATEFILES IL:_ (IL:FUNCTION 
IL:\\GENERATENOFILES) IL:RENAMEFILE IL:_ (IL:FUNCTION IL:NILL) IL:BIN IL:_ (IL:FUNCTION 
IL:\\ILLEGAL.DEVICEOP) IL:BOUT IL:_ (IL:FUNCTION IL:NILL) IL:PEEKBIN IL:_ (IL:FUNCTION 
IL:\\ILLEGAL.DEVICEOP) IL:READP IL:_ (IL:FUNCTION IL:\\ILLEGAL.DEVICEOP) IL:EOFP IL:_ (IL:FUNCTION 
IL:NILL) IL:BLOCKIN IL:_ (IL:FUNCTION IL:\\ILLEGAL.DEVICEOP) IL:BLOCKOUT IL:_ (IL:FUNCTION 
IL:\\GENERIC.BOUTS) IL:FORCEOUTPUT IL:_ (IL:FUNCTION IL:NILL) IL:GETFILEPTR IL:_ (IL:FUNCTION 
IL:\\ILLEGAL.DEVICEOP) IL:SETFILEINFO IL:_ (IL:FUNCTION IL:\\ILLEGAL.DEVICEOP)))
(DEFUN XP-STREAM-OUTCHARFN (STREAM CHARNO) (IL:* IL:|;;| 
"For the moment, keep it simple.  We'll gussy this up with block stuff later.  For now, we assume no newlines or other white-space junk in this function"
) (WRITE-CHAR++ (INT-CHAR CHARNO) STREAM))
(DEFUN XP-STREAM-DEVICE-CLOSEFILE (STREAM &OPTIONAL IL:ABORTFLAG) (IL:* IL:|;;| 
"What the heck, close the underlying \"real\" stream") (CLOSE (BASE-STREAM (IL:|fetch| IL:F1 IL:|of| 
STREAM))))
(DEFUN INSTALL (&KEY (PACKAGE *PACKAGE*) (MACRO IL:NIL) (SHADOW T) (REMOVE IL:NIL)) (WHEN (NOT (
PACKAGEP PACKAGE)) (SETQ PACKAGE (FIND-PACKAGE PACKAGE))) (WHEN (NOT REMOVE) (WHEN MACRO (
SET-DISPATCH-MACRO-CHARACTER #\# #\" (FUNCTION FORMAT-STRING-READER))) (WHEN (NOT (EQ PACKAGE (
FIND-PACKAGE "XP"))) (USE-PACKAGE "XP" PACKAGE) (WHEN SHADOW (SHADOWING-IMPORT *XP-PRINTING-FUNCTIONS*
 PACKAGE)))) (WHEN (AND REMOVE (MEMBER (FIND-PACKAGE "XP") (PACKAGE-USE-LIST PACKAGE))) (UNUSE-PACKAGE
 "XP" PACKAGE) (DOLIST (SYM (INTERSECTION *XP-PRINTING-FUNCTIONS* (PACKAGE-SHADOWING-SYMBOLS PACKAGE))
) (UNINTERN SYM PACKAGE))) T)
(DEFVAR *LOCATING-CIRCULARITIES* IL:NIL 
"Integer if making a first pass over things to identify circularities.
   Integer used as counter for #n= syntax.")
(DEFVAR *PARENTS* IL:NIL "used when *print-shared* is nil")
(DEFVAR *CIRCULARITY-HASH-TABLE* IL:NIL 
"Contains hash table used for locating circularities, or a stack.")
(DEFVAR *FREE-CIRCULARITY-HASH-TABLES* IL:NIL "free list of circularity hash tables")
(DEFUN GET-CIRCULARITY-HASH-TABLE IL:NIL (LET ((TABLE (POP *FREE-CIRCULARITY-HASH-TABLES*))) (IF TABLE
 TABLE (MAKE-HASH-TABLE :TEST (QUOTE EQ)))))
(DEFUN FREE-CIRCULARITY-HASH-TABLE (TABLE) (CLRHASH TABLE) (PUSHNEW TABLE 
*FREE-CIRCULARITY-HASH-TABLES*))
(CL:DEFSTRUCT (PPRINT-DISPATCH (:CONC-NAME IL:NIL) (:COPIER IL:NIL) (:FAST-ACCESSORS T)) (
CONSES-WITH-CARS (MAKE-HASH-TABLE :TEST (FUNCTION EQ)) :TYPE HASH-TABLE) (STRUCTURES (MAKE-HASH-TABLE 
:TEST (FUNCTION EQ)) :TYPE HASH-TABLE) (OTHERS IL:NIL :TYPE LIST))
(CL:DEFSTRUCT (ENTRY (:CONC-NAME IL:NIL) (:FAST-ACCESSORS T)) (TEST IL:NIL) (IL:* IL:|;;| 
"predicate function or count of higher priority others.") (FN IL:NIL) (IL:* IL:\; "pprint function") (
FULL-SPEC IL:NIL))
(DEFUN COPY-PPRINT-DISPATCH (&OPTIONAL (TABLE *PRINT-PPRINT-DISPATCH*)) (WHEN (NULL TABLE) (SETQ TABLE
 *IPD*)) (LET* ((NEW-CONSES-WITH-CARS (MAKE-HASH-TABLE :TEST (FUNCTION EQ) :SIZE (MAX (
HASH-TABLE-COUNT (CONSES-WITH-CARS TABLE)) 32))) (NEW-STRUCTURES (MAKE-HASH-TABLE :TEST (FUNCTION EQ) 
:SIZE (MAX (HASH-TABLE-COUNT (STRUCTURES TABLE)) 32)))) (MAPHASH (FUNCTION (LAMBDA (KEY VALUE) (SETF (
GETHASH KEY NEW-CONSES-WITH-CARS) (COPY-ENTRY VALUE)))) (CONSES-WITH-CARS TABLE)) (MAPHASH (FUNCTION (
LAMBDA (KEY VALUE) (SETF (GETHASH KEY NEW-STRUCTURES) (COPY-ENTRY VALUE)))) (STRUCTURES TABLE)) (
MAKE-PPRINT-DISPATCH :CONSES-WITH-CARS NEW-CONSES-WITH-CARS :STRUCTURES NEW-STRUCTURES :OTHERS (
COPY-LIST (OTHERS TABLE)))))
(DEFUN SET-PPRINT-DISPATCH (TYPE-SPECIFIER FUNCTION &OPTIONAL (PRIORITY 0) (TABLE 
*PRINT-PPRINT-DISPATCH*)) (WHEN (OR (NOT (NUMBERP PRIORITY)) (COMPLEXP PRIORITY)) (ERROR 
"invalid PRIORITY argument ~A to SET-PPRINT-DISPATCH" PRIORITY)) (SET-PPRINT-DISPATCH+ TYPE-SPECIFIER 
FUNCTION PRIORITY TABLE))
(DEFUN SET-PPRINT-DISPATCH+ (TYPE-SPECIFIER FUNCTION PRIORITY TABLE) (LET* ((CATEGORY (
SPECIFIER-CATEGORY TYPE-SPECIFIER)) (PRED (IF (NOT (EQ CATEGORY (QUOTE OTHER))) IL:NIL (LET ((PRED (
SPECIFIER-FN TYPE-SPECIFIER))) (IF (AND (CONSP (CADDR PRED)) (SYMBOLP (CAADDR PRED)) (EQUAL (CDADDR 
PRED) (QUOTE (X)))) (SYMBOL-FUNCTION (CAADDR PRED)) (COMPILE IL:NIL PRED))))) (ENTRY (IF FUNCTION (
MAKE-ENTRY :TEST PRED :FN FUNCTION :FULL-SPEC (LIST PRIORITY TYPE-SPECIFIER))))) (CASE CATEGORY (
CONS-WITH-CAR (COND ((NULL ENTRY) (REMHASH (CADADR TYPE-SPECIFIER) (CONSES-WITH-CARS TABLE))) (T (SETF
 (TEST ENTRY) (COUNT-IF (FUNCTION (LAMBDA (E) (PRIORITY-> (CAR (FULL-SPEC E)) PRIORITY))) (OTHERS 
TABLE))) (SETF (GETHASH (CADADR TYPE-SPECIFIER) (CONSES-WITH-CARS TABLE)) ENTRY)))) (STRUCTURE-TYPE (
COND ((NULL ENTRY) (REMHASH TYPE-SPECIFIER (STRUCTURES TABLE))) (T (SETF (TEST ENTRY) (COUNT-IF (
FUNCTION (LAMBDA (E) (PRIORITY-> (CAR (FULL-SPEC E)) PRIORITY))) (OTHERS TABLE))) (SETF (GETHASH 
TYPE-SPECIFIER (STRUCTURES TABLE)) ENTRY)))) (T (IL:* IL:\; "other") (LET ((OLD (CAR (MEMBER 
TYPE-SPECIFIER (OTHERS TABLE) :TEST (FUNCTION EQUAL) :KEY (FUNCTION (LAMBDA (E) (CADR (FULL-SPEC E))))
)))) (WHEN OLD (SETF (OTHERS TABLE) (DELETE OLD (OTHERS TABLE))) (ADJUST-COUNTS TABLE (CAR (FULL-SPEC 
OLD)) -1))) (WHEN ENTRY (LET ((OTHERS (CONS IL:NIL (OTHERS TABLE)))) (DO ((L OTHERS (CDR L))) ((NULL (
CDR L)) (RPLACD L (LIST ENTRY))) (WHEN (PRIORITY-> PRIORITY (CAR (FULL-SPEC (CADR L)))) (RPLACD L (
CONS ENTRY (CDR L))) (RETURN IL:NIL))) (SETF (OTHERS TABLE) (CDR OTHERS))) (ADJUST-COUNTS TABLE 
PRIORITY 1))))) IL:NIL)
(DEFUN PRIORITY-> (X Y) (IF (CONSP X) (IF (CONSP Y) (> (CAR X) (CAR Y)) IL:NIL) (IF (CONSP Y) T (> X Y
))))
(DEFUN ADJUST-COUNTS (TABLE PRIORITY DELTA) (MAPHASH (FUNCTION (LAMBDA (KEY VALUE) (DECLARE (IGNORE 
KEY)) (IF (PRIORITY-> PRIORITY (CAR (FULL-SPEC VALUE))) (INCF (TEST VALUE) DELTA)))) (CONSES-WITH-CARS
 TABLE)) (MAPHASH (FUNCTION (LAMBDA (KEY VALUE) (DECLARE (IGNORE KEY)) (IF (PRIORITY-> PRIORITY (CAR (
FULL-SPEC VALUE))) (INCF (TEST VALUE) DELTA)))) (STRUCTURES TABLE)))
(DEFUN PPRINT-DISPATCH (OBJECT &OPTIONAL (TABLE *PRINT-PPRINT-DISPATCH*)) (WHEN (NULL TABLE) (SETQ 
TABLE *IPD*)) (LET ((FN (GET-PRINTER OBJECT TABLE))) (VALUES (OR FN (FUNCTION NON-PRETTY-PRINT)) (NOT 
(NULL FN)))))
(DEFUN GET-PRINTER (OBJECT TABLE) (LET ((ENTRY (IF (CONSP OBJECT) (GETHASH (CAR OBJECT) (
CONSES-WITH-CARS TABLE)) (GETHASH (TYPE-OF OBJECT) (STRUCTURES TABLE))))) (IF (NOT ENTRY) (IL:* IL:|;;|
 "(SETQ ENTRY (FIND OBJECT (OTHERS TABLE) :TEST #'FITS))  ") (IL:* IL:|;;| "Equivalent code below") (
DO ((L (OTHERS TABLE) (CDR L))) ((COND ((NULL L)) ((FUNCALL (TEST (CAR L)) OBJECT) (SETQ ENTRY (CAR L)
))))) (DO ((I (TEST ENTRY) (1- I)) (L (OTHERS TABLE) (CDR L))) ((ZEROP I)) (WHEN (IL:* IL:|;;| 
"(FITS OBJECT (CAR L))") (IL:* IL:|;;| "Equivalent code below ") (FUNCALL (TEST (CAR L)) OBJECT) (SETQ
 ENTRY (CAR L)) (RETURN IL:NIL)))) (WHEN ENTRY (FN ENTRY))))
(DEFUN FITS (OBJ ENTRY) (FUNCALL (TEST ENTRY) OBJ))
(DEFUN SPECIFIER-CATEGORY (SPEC) (COND ((AND (CONSP SPEC) (EQ (CAR SPEC) (QUOTE CONS)) (CONSP (CDR 
SPEC)) (NULL (CDDR SPEC)) (CONSP (CADR SPEC)) (EQ (CAADR SPEC) (QUOTE MEMBER)) (CONSP (CDADR SPEC)) (
NULL (CDDADR SPEC))) (QUOTE CONS-WITH-CAR)) ((AND (SYMBOLP SPEC) (STRUCTURE-TYPE-P SPEC)) (QUOTE 
STRUCTURE-TYPE)) (T (QUOTE OTHER))))
(DEFVAR *PREDS-FOR-SPECS* (QUOTE ((T ALWAYS-TRUE) (CONS CONSP) (SIMPLE-ATOM SIMPLE-ATOM-P) (OTHER 
OTHERP) (NULL NULL) (SYMBOL SYMBOLP) (ATOM ATOM) (CONS CONSP) (LIST LISTP) (NUMBER NUMBERP) (INTEGER 
INTEGERP) (RATIONAL RATIONALP) (FLOAT FLOATP) (COMPLEX COMPLEXP) (CHARACTER CHARACTERP) (STRING 
STRINGP) (BIT-VECTOR BIT-VECTOR-P) (VECTOR VECTORP) (SIMPLE-VECTOR SIMPLE-VECTOR-P) (SIMPLE-STRING 
SIMPLE-STRING-P) (SIMPLE-BIT-VECTOR SIMPLE-BIT-VECTOR-P) (ARRAY ARRAYP) (PACKAGE PACKAGEP) (FUNCTION 
FUNCTIONP) (COMPILED-FUNCTION COMPILED-FUNCTION-P) (COMMON COMMONP))))
(DEFUN ALWAYS-TRUE (X) (DECLARE (IGNORE X)) T)
(DEFUN SPECIFIER-FN (SPEC) (IL:BQUOTE (LAMBDA (X) (IL:\\\, (CONVERT-BODY SPEC)))))
(DEFUN CONVERT-BODY (SPEC) (COND ((ATOM SPEC) (LET ((PRED (CADR (ASSOC SPEC *PREDS-FOR-SPECS*)))) (IF 
PRED (IL:BQUOTE ((IL:\\\, PRED) X)) (IL:BQUOTE (TYPEP X (QUOTE (IL:\\\, SPEC))))))) ((MEMBER (CAR SPEC
) (QUOTE (AND OR NOT))) (CONS (CAR SPEC) (MAPCAR (FUNCTION CONVERT-BODY) (CDR SPEC)))) ((EQ (CAR SPEC)
 (QUOTE MEMBER)) (IL:BQUOTE (MEMBER X (QUOTE (IL:\\\, (COPY-LIST (CDR SPEC))))))) ((EQ (CAR SPEC) (
QUOTE CONS)) (IL:BQUOTE (AND (CONSP X) (IL:\\\,@ (IF (CDR SPEC) (IL:BQUOTE ((LET ((X (CAR X))) (IL:\\\,
 (CONVERT-BODY (CADR SPEC)))))))) (IL:\\\,@ (IF (CDDR SPEC) (IL:BQUOTE ((LET ((X (CDR X))) (IL:\\\, (
CONVERT-BODY (CADDR SPEC))))))))))) ((EQ (CAR SPEC) (QUOTE SATISFIES)) (IL:BQUOTE (FUNCALL (FUNCTION (
IL:\\\, (CADR SPEC))) X))) (T (IL:BQUOTE (TYPEP X (QUOTE (IL:\\\, (COPY-TREE SPEC))))))))
(DEFVAR BLOCK-STACK-ENTRY-SIZE 1)
(DEFVAR PREFIX-STACK-ENTRY-SIZE 5)
(DEFVAR QUEUE-ENTRY-SIZE 7)
(DEFVAR BUFFER-ENTRY-SIZE 1)
(DEFVAR PREFIX-ENTRY-SIZE 1)
(DEFVAR SUFFIX-ENTRY-SIZE 1)
(DEFVAR BLOCK-STACK-MIN-SIZE 35)
(DEFVAR PREFIX-STACK-MIN-SIZE 150)
(DEFVAR QUEUE-MIN-SIZE 525)
(DEFVAR BUFFER-MIN-SIZE 256)
(DEFVAR PREFIX-MIN-SIZE 256)
(DEFVAR SUFFIX-MIN-SIZE 256)
(IL:BLOCKRECORD XP-STRUCTURE ((BUFFER-OFFSET IL:SIGNEDWORD) (BUFFER-PTR IL:SIGNEDWORD) (BUFFER 
IL:POINTER) (IL:BYTESIZE BYTE) (IL:NIL BYTE) (IL:NIL IL:SIGNEDWORD) (CHARPOS IL:SIGNEDWORD) (
DEPTH-IN-BLOCKS IL:SIGNEDWORD) (IL:NIL IL:POINTER) (IL:NIL IL:POINTER) (IL:NIL IL:POINTER) (IL:NIL 
IL:POINTER) (CHAR-MODE IL:POINTER) (CHAR-MODE-COUNTER IL:SIGNEDWORD) (LINEL IL:SIGNEDWORD) (
BASE-STREAM IL:POINTER) (BLOCK-STACK IL:POINTER) (QUEUE IL:POINTER) (PREFIX IL:POINTER) (PREFIX-STACK 
IL:POINTER) (QLEFT IL:SIGNEDWORD) (QRIGHT IL:SIGNEDWORD) (BLOCK-STACK-PTR IL:SIGNEDWORD) (
PREFIX-STACK-PTR IL:SIGNEDWORD) (SUFFIX IL:POINTER) (IL:NIL IL:POINTER) (IL:NIL IL:POINTER) (IL:NIL 
IL:POINTER) (IL:NIL IL:POINTER) (IL:NIL IL:POINTER) (IL:NIL IL:POINTER) (IL:NIL IL:POINTER) (IL:NIL 
IL:POINTER) (IL:NIL IL:SIGNEDWORD) (LINE-NO IL:SIGNEDWORD) (LINE-LIMIT IL:POINTER)))
(DEFMACRO BASE-STREAM (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE BASE-STREAM) IL:|of| (IL:\\\, XP))))
(DEFMACRO LINEL (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE LINEL) IL:|of| (IL:\\\, XP))))
(DEFMACRO LINE-LIMIT (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE LINE-LIMIT) IL:|of| (IL:\\\, XP))))
(DEFMACRO LINE-NO (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE LINE-NO) IL:|of| (IL:\\\, XP))))
(DEFMACRO CHAR-MODE (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE CHAR-MODE) IL:|of| (IL:\\\, XP))))
(DEFMACRO CHAR-MODE-COUNTER (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE CHAR-MODE-COUNTER) IL:|of| (
IL:\\\, XP))))
(DEFMACRO DEPTH-IN-BLOCKS (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE DEPTH-IN-BLOCKS) IL:|of| (IL:\\\, 
XP))))
(DEFMACRO BLOCK-STACK (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE BLOCK-STACK) IL:|of| (IL:\\\, XP))))
(DEFMACRO BLOCK-STACK-PTR (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE BLOCK-STACK-PTR) IL:|of| (IL:\\\, 
XP))))
(DEFMACRO BUFFER (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE BUFFER) IL:|of| (IL:\\\, XP))))
(DEFMACRO CHARPOS (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE CHARPOS) IL:|of| (IL:\\\, XP))))
(DEFMACRO BUFFER-PTR (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE BUFFER-PTR) IL:|of| (IL:\\\, XP))))
(DEFMACRO BUFFER-OFFSET (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE BUFFER-OFFSET) IL:|of| (IL:\\\, XP))
))
(DEFMACRO QUEUE (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE QUEUE) IL:|of| (IL:\\\, XP))))
(DEFMACRO QLEFT (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE QLEFT) IL:|of| (IL:\\\, XP))))
(DEFMACRO QRIGHT (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE QRIGHT) IL:|of| (IL:\\\, XP))))
(DEFMACRO PREFIX (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE PREFIX) IL:|of| (IL:\\\, XP))))
(DEFMACRO PREFIX-STACK (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE PREFIX-STACK) IL:|of| (IL:\\\, XP))))
(DEFMACRO PREFIX-STACK-PTR (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE PREFIX-STACK-PTR) IL:|of| (IL:\\\,
 XP))))
(DEFMACRO SUFFIX (XP) (IL:BQUOTE (IL:|fetch| (XP-STRUCTURE SUFFIX) IL:|of| (IL:\\\, XP))))
(DEFUN MAKE-XP-STRUCTURE (&KEY (BASE-STREAM IL:NIL) (BLOCK-STACK (MAKE-ARRAY 35)) (BUFFER (MAKE-ARRAY 
256 :ELEMENT-TYPE (QUOTE STRING-CHAR))) (QUEUE (MAKE-ARRAY 525)) (PREFIX (MAKE-ARRAY 256 :ELEMENT-TYPE
 (QUOTE STRING-CHAR))) (PREFIX-STACK (MAKE-ARRAY 150)) (SUFFIX (MAKE-ARRAY 256 :ELEMENT-TYPE (QUOTE 
STRING-CHAR))) (LINEL 0) (LINE-LIMIT 65535) (LINE-NO 0) (DEPTH-IN-BLOCKS 0) (BLOCK-STACK-PTR 0) (
CHARPOS 0) (BUFFER-PTR 0) (BUFFER-OFFSET 0) (QLEFT 0) (QRIGHT 0) (PREFIX-STACK-PTR 0)) (LET ((XP (
IL:|create| STREAM IL:DEVICE IL:_ *XP-STREAM-DEVICE* IL:ACCESS IL:_ (QUOTE IL:OUTPUT) IL:OTHERPROPS IL:_
 (QUOTE (*XP-STREAM-DEVICE* T)) IL:OUTCHARFN IL:_ (IL:FUNCTION XP-STREAM-OUTCHARFN) IL:STRMBOUTFN IL:_
 (IL:FUNCTION IL:\\OUTCHAR)))) (SETF (BUFFER XP) BUFFER) (SETF (BASE-STREAM XP) BASE-STREAM) (SETF (
BLOCK-STACK XP) BLOCK-STACK) (SETF (QUEUE XP) QUEUE) (SETF (PREFIX XP) PREFIX) (SETF (PREFIX-STACK XP)
 PREFIX-STACK) (SETF (SUFFIX XP) SUFFIX) (SETF (LINEL XP) LINEL) (SETF (LINE-LIMIT XP) LINE-LIMIT) (
SETF (LINE-NO XP) LINE-NO) (SETF (DEPTH-IN-BLOCKS XP) DEPTH-IN-BLOCKS) (SETF (BLOCK-STACK-PTR XP) 
BLOCK-STACK-PTR) (SETF (CHARPOS XP) CHARPOS) (SETF (BUFFER-PTR XP) BUFFER-PTR) (SETF (BUFFER-OFFSET XP
) BUFFER-OFFSET) (SETF (QLEFT XP) QLEFT) (SETF (QRIGHT XP) QRIGHT) (SETF (PREFIX-STACK-PTR XP) 
PREFIX-STACK-PTR) XP))
(DEFMACRO XP-STRUCTURE-P (OBJECT) (IL:BQUOTE (AND (TYPEP (IL:\\\, OBJECT) (QUOTE STREAM)) (EQ (
IL:|fetch| (STREAM IL:DEVICE) IL:|of| (IL:\\\, OBJECT)) *XP-STREAM-DEVICE*))))
(DEFMACRO LP<-BP (XP &OPTIONAL (PTR IL:NIL)) (IF (NULL PTR) (SETQ PTR (IL:BQUOTE (BUFFER-PTR (IL:\\\, 
XP))))) (IL:BQUOTE (+ (IL:\\\, PTR) (CHARPOS (IL:\\\, XP)))))
(DEFMACRO TP<-BP (XP) (IL:BQUOTE (+ (BUFFER-PTR (IL:\\\, XP)) (BUFFER-OFFSET (IL:\\\, XP)))))
(DEFMACRO BP<-LP (XP PTR) (IL:BQUOTE (- (IL:\\\, PTR) (CHARPOS (IL:\\\, XP)))))
(DEFMACRO BP<-TP (XP PTR) (IL:BQUOTE (- (IL:\\\, PTR) (BUFFER-OFFSET (IL:\\\, XP)))))
(DEFMACRO LP<-TP (XP PTR) (IL:BQUOTE (LP<-BP (IL:\\\, XP) (BP<-TP (IL:\\\, XP) (IL:\\\, PTR)))))
(DEFMACRO CHECK-SIZE (XP VECT PTR) (LET* ((MIN-SIZE (SYMBOL-VALUE (INTERN (CONCATENATE (QUOTE STRING) 
(STRING VECT) "-MIN-SIZE") (FIND-PACKAGE "XP")))) (ENTRY-SIZE (SYMBOL-VALUE (INTERN (CONCATENATE (
QUOTE STRING) (STRING VECT) "-ENTRY-SIZE") (FIND-PACKAGE "XP"))))) (IL:BQUOTE (WHEN (AND (> (IL:\\\, 
PTR) (IL:\\\, (- MIN-SIZE ENTRY-SIZE))) (IL:* IL:\; "seldom happens") (> (IL:\\\, PTR) (- (LENGTH ((
IL:\\\, VECT) (IL:\\\, XP))) (IL:\\\, ENTRY-SIZE)))) (LET* ((OLD ((IL:\\\, VECT) (IL:\\\, XP))) (NEW (
MAKE-ARRAY (+ (IL:\\\, PTR) (IL:\\\, (IF (= ENTRY-SIZE 1) 50 (* 10 ENTRY-SIZE)))) :ELEMENT-TYPE (
ARRAY-ELEMENT-TYPE OLD)))) (REPLACE NEW OLD) (SETF ((IL:\\\, VECT) (IL:\\\, XP)) NEW))))))
(DEFMACRO SECTION-START (XP) (IL:BQUOTE (AREF (BLOCK-STACK (IL:\\\, XP)) (BLOCK-STACK-PTR (IL:\\\, XP)
))))
(DEFUN PUSH-BLOCK-STACK (XP) (INCF (BLOCK-STACK-PTR XP) 1) (CHECK-SIZE XP BLOCK-STACK (BLOCK-STACK-PTR
 XP)))
(DEFUN POP-BLOCK-STACK (XP) (IL:* IL:\; "Edited 10-Jun-92 19:54 by jrb:") (DECF (BLOCK-STACK-PTR XP) 1
))
(DEFMACRO PREFIX-PTR (XP) (IL:BQUOTE (AREF (PREFIX-STACK (IL:\\\, XP)) (PREFIX-STACK-PTR (IL:\\\, XP))
)))
(DEFMACRO SUFFIX-PTR (XP) (IL:BQUOTE (AREF (PREFIX-STACK (IL:\\\, XP)) (+ (PREFIX-STACK-PTR (IL:\\\, 
XP)) 1))))
(DEFMACRO NON-BLANK-PREFIX-PTR (XP) (IL:BQUOTE (AREF (PREFIX-STACK (IL:\\\, XP)) (+ (PREFIX-STACK-PTR 
(IL:\\\, XP)) 2))))
(DEFMACRO INITIAL-PREFIX-PTR (XP) (IL:BQUOTE (AREF (PREFIX-STACK (IL:\\\, XP)) (+ (PREFIX-STACK-PTR (
IL:\\\, XP)) 3))))
(DEFMACRO SECTION-START-LINE (XP) (IL:BQUOTE (AREF (PREFIX-STACK (IL:\\\, XP)) (+ (PREFIX-STACK-PTR (
IL:\\\, XP)) 4))))
(DEFUN PUSH-PREFIX-STACK (XP) (LET ((OLD-PREFIX 0) (OLD-SUFFIX 0) (OLD-NON-BLANK 0)) (WHEN (NOT (
MINUSP (PREFIX-STACK-PTR XP))) (SETQ OLD-PREFIX (PREFIX-PTR XP) OLD-SUFFIX (SUFFIX-PTR XP) 
OLD-NON-BLANK (NON-BLANK-PREFIX-PTR XP))) (INCF (PREFIX-STACK-PTR XP) 5) (CHECK-SIZE XP PREFIX-STACK (
PREFIX-STACK-PTR XP)) (SETF (PREFIX-PTR XP) OLD-PREFIX) (SETF (SUFFIX-PTR XP) OLD-SUFFIX) (SETF (
NON-BLANK-PREFIX-PTR XP) OLD-NON-BLANK)))
(DEFUN POP-PREFIX-STACK (XP) (DECF (PREFIX-STACK-PTR XP) 5))
(DEFMACRO QTYPE (XP INDEX) (IL:BQUOTE (AREF (QUEUE (IL:\\\, XP)) (IL:\\\, INDEX))))
(DEFMACRO QKIND (XP INDEX) (IL:BQUOTE (AREF (QUEUE (IL:\\\, XP)) (1+ (IL:\\\, INDEX)))))
(DEFMACRO QPOS (XP INDEX) (IL:BQUOTE (AREF (QUEUE (IL:\\\, XP)) (+ (IL:\\\, INDEX) 2))))
(DEFMACRO QDEPTH (XP INDEX) (IL:BQUOTE (AREF (QUEUE (IL:\\\, XP)) (+ (IL:\\\, INDEX) 3))))
(DEFMACRO QEND (XP INDEX) (IL:BQUOTE (AREF (QUEUE (IL:\\\, XP)) (+ (IL:\\\, INDEX) 4))))
(DEFMACRO QOFFSET (XP INDEX) (IL:BQUOTE (AREF (QUEUE (IL:\\\, XP)) (+ (IL:\\\, INDEX) 5))))
(DEFMACRO QARG (XP INDEX) (IL:BQUOTE (AREF (QUEUE (IL:\\\, XP)) (+ (IL:\\\, INDEX) 6))))
(DEFUN ENQUEUE (XP TYPE KIND &OPTIONAL ARG) (INCF (QRIGHT XP) 7) (WHEN (> (QRIGHT XP) 518) (IL:* IL:|;;|
 "Equivalent code below, assuming the queue is an array") (IL:* IL:|;;| 
"(DO ((S1 0 (INCF S1)) (S2 (QLEFT XP) (INCF S2)) (E2 (QRIGHT XP)) (Q (QUEUE XP))) ((IL:IGREATERP S2 E2)) (SETF (AREF Q S1) (AREF Q S2)))"
) (REPLACE (QUEUE XP) (QUEUE XP) :START2 (QLEFT XP) :END2 (QRIGHT XP)) (SETF (QRIGHT XP) (- (QRIGHT XP
) (QLEFT XP))) (SETF (QLEFT XP) 0)) (CHECK-SIZE XP QUEUE (QRIGHT XP)) (SETF (QTYPE XP (QRIGHT XP)) 
TYPE) (SETF (QKIND XP (QRIGHT XP)) KIND) (SETF (QPOS XP (QRIGHT XP)) (TP<-BP XP)) (SETF (QDEPTH XP (
QRIGHT XP)) (DEPTH-IN-BLOCKS XP)) (SETF (QEND XP (QRIGHT XP)) IL:NIL) (SETF (QOFFSET XP (QRIGHT XP)) 
IL:NIL) (SETF (QARG XP (QRIGHT XP)) ARG))
(DEFMACRO QNEXT (INDEX) (IL:BQUOTE (+ (IL:\\\, INDEX) 7)))
(DEFVAR *DESCRIBE-XP-STREAMS-FULLY* IL:NIL "Set to T to see more info.")
(DEFUN DESCRIBE-XP (XP S DEPTH) (DECLARE (IGNORE DEPTH)) (CL:FORMAT S "#<XP stream ") (IF (NOT (
BASE-STREAM XP)) (CL:FORMAT S "not currently in use") (CL:FORMAT S "outputting to ~S" (BASE-STREAM XP)
)) (WHEN (BASE-STREAM XP) (CL:FORMAT S "~&buffer= ~S" (SUBSEQ (BUFFER XP) 0 (MAX (BUFFER-PTR XP) 0))) 
(WHEN (NOT *DESCRIBE-XP-STREAMS-FULLY*) (CL:PRINC " ..." S)) (WHEN *DESCRIBE-XP-STREAMS-FULLY* (
CL:FORMAT S "~&   pos   _123456789_123456789_123456789_123456789") (CL:FORMAT S 
"~&depth-in-blocks= ~D linel= ~D line-no= ~D line-limit= ~D" (DEPTH-IN-BLOCKS XP) (LINEL XP) (LINE-NO 
XP) (LINE-LIMIT XP)) (WHEN (OR (CHAR-MODE XP) (NOT (ZEROP (CHAR-MODE-COUNTER XP)))) (CL:FORMAT S 
"~&char-mode= ~S char-mode-counter= ~D" (CHAR-MODE XP) (CHAR-MODE-COUNTER XP))) (UNLESS (MINUSP (
BLOCK-STACK-PTR XP)) (CL:FORMAT S "~&section-start") (DO ((SAVE (BLOCK-STACK-PTR XP))) ((MINUSP (
BLOCK-STACK-PTR XP)) (SETF (BLOCK-STACK-PTR XP) SAVE)) (CL:FORMAT S " ~D" (SECTION-START XP)) (
POP-BLOCK-STACK XP))) (CL:FORMAT S "~&linel= ~D charpos= ~D buffer-ptr= ~D buffer-offset= ~D" (LINEL 
XP) (CHARPOS XP) (BUFFER-PTR XP) (BUFFER-OFFSET XP)) (UNLESS (MINUSP (PREFIX-STACK-PTR XP)) (CL:FORMAT
 S "~&prefix= ~S" (SUBSEQ (PREFIX XP) 0 (MAX (PREFIX-PTR XP) 0))) (CL:FORMAT S "~&suffix= ~S" (SUBSEQ 
(SUFFIX XP) 0 (MAX (SUFFIX-PTR XP) 0)))) (UNLESS (> (QLEFT XP) (QRIGHT XP)) (CL:FORMAT S 
"~&ptr type         kind           pos depth end offset arg") (DO ((P (QLEFT XP) (QNEXT P))) ((> P (
QRIGHT XP))) (CL:FORMAT S "~&~4A~13A~15A~4A~6A~4A~7A~A" (/ (- P (QLEFT XP)) 7) (QTYPE XP P) (IF (
MEMBER (QTYPE XP P) (QUOTE (:NEWLINE :IND))) (QKIND XP P) "") (BP<-TP XP (QPOS XP P)) (QDEPTH XP P) (
IF (NOT (MEMBER (QTYPE XP P) (QUOTE (:NEWLINE :START-BLOCK)))) "" (AND (QEND XP P) (/ (- (+ P (QEND XP
 P)) (QLEFT XP)) 7))) (IF (NOT (EQ (QTYPE XP P) :START-BLOCK)) "" (AND (QOFFSET XP P) (/ (- (+ P (
QOFFSET XP P)) (QLEFT XP)) 7))) (IF (NOT (MEMBER (QTYPE XP P) (QUOTE (:IND :START-BLOCK :END-BLOCK))))
 "" (QARG XP P))))) (UNLESS (MINUSP (PREFIX-STACK-PTR XP)) (CL:FORMAT S 
"~&initial-prefix-ptr prefix-ptr suffix-ptr non-blank start-line") (DO ((SAVE (PREFIX-STACK-PTR XP))) 
((MINUSP (PREFIX-STACK-PTR XP)) (SETF (PREFIX-STACK-PTR XP) SAVE)) (CL:FORMAT S 
"~& ~19A~11A~11A~10A~A" (INITIAL-PREFIX-PTR XP) (PREFIX-PTR XP) (SUFFIX-PTR XP) (NON-BLANK-PREFIX-PTR 
XP) (SECTION-START-LINE XP)) (POP-PREFIX-STACK XP))))) (CL:PRINC ">" S) (VALUES))
(DEFVAR *FREE-XPS* IL:NIL "free list of XP stream objects")
(DEFUN GET-PRETTY-PRINT-STREAM (STREAM) (LET ((XP (POP *FREE-XPS*))) (INITIALIZE-XP (IF XP XP (
MAKE-XP-STRUCTURE)) STREAM)))
(DEFUN FREE-PRETTY-PRINT-STREAM (XP) (SETF (BASE-STREAM XP) IL:NIL) (PUSHNEW XP *FREE-XPS*))
(DEFUN INITIALIZE-XP (XP STREAM) (SETF (BASE-STREAM XP) STREAM) (SETF (LINEL XP) (MAX 0 (COND (
*PRINT-RIGHT-MARGIN*) ((OUTPUT-WIDTH STREAM)) (T *DEFAULT-RIGHT-MARGIN*)))) (SETF (LINE-LIMIT XP) 
*PRINT-LINES*) (SETF (LINE-NO XP) 1) (SETF (CHAR-MODE XP) IL:NIL) (SETF (CHAR-MODE-COUNTER XP) 0) (
SETF (DEPTH-IN-BLOCKS XP) 0) (SETF (BLOCK-STACK-PTR XP) 0) (SETF (CHARPOS XP) (COND ((OUTPUT-POSITION 
STREAM)) (T 0))) (SETF (SECTION-START XP) 0) (SETF (BUFFER-PTR XP) 0) (SETF (BUFFER-OFFSET XP) (
CHARPOS XP)) (SETF (QLEFT XP) 0) (SETF (QRIGHT XP) -7) (SETF (PREFIX-STACK-PTR XP) -5) XP)
(DEFUN PUSH-CHAR-MODE (XP NEW-MODE) (IF (ZEROP (CHAR-MODE-COUNTER XP)) (SETF (CHAR-MODE XP) NEW-MODE))
 (INCF (CHAR-MODE-COUNTER XP)))
(DEFUN POP-CHAR-MODE (XP) (DECF (CHAR-MODE-COUNTER XP)) (IF (ZEROP (CHAR-MODE-COUNTER XP)) (SETF (
CHAR-MODE XP) IL:NIL)))
(DEFUN HANDLE-CHAR-MODE (XP CHAR) (CASE (CHAR-MODE XP) (:CAP0 (COND ((NOT (ALPHANUMERICP CHAR)) CHAR) 
(T (SETF (CHAR-MODE XP) :DOWN) (CHAR-UPCASE CHAR)))) (:CAP1 (COND ((NOT (ALPHANUMERICP CHAR)) CHAR) (T
 (SETF (CHAR-MODE XP) :CAPW) (CHAR-UPCASE CHAR)))) (:CAPW (COND ((ALPHANUMERICP CHAR) (CHAR-DOWNCASE 
CHAR)) (T (SETF (CHAR-MODE XP) :CAP1) CHAR))) (:UP (CHAR-UPCASE CHAR)) (T (CHAR-DOWNCASE CHAR))))
(DEFUN WRITE-CHAR+ (CHAR XP) (IF (EQL CHAR #\Newline) (PPRINT-NEWLINE+ :UNCONDITIONAL XP) (
WRITE-CHAR++ CHAR XP)))
(DEFUN WRITE-STRING+ (STRING XP START END) (LET ((SUB-END IL:NIL) NEXT-NEWLINE) (LOOP (SETQ 
NEXT-NEWLINE (POSITION #\Newline STRING :TEST (FUNCTION CHAR=) :START START :END END)) (SETQ SUB-END (
IF NEXT-NEWLINE NEXT-NEWLINE END)) (WRITE-STRING++ STRING XP START SUB-END) (WHEN (NULL NEXT-NEWLINE) 
(RETURN IL:NIL)) (PPRINT-NEWLINE+ :UNCONDITIONAL XP) (SETQ START (1+ SUB-END)))))
(DEFUN WRITE-CHAR++ (CHAR XP) (WHEN (> (BUFFER-PTR XP) (LINEL XP)) (FORCE-SOME-OUTPUT XP)) (LET ((
NEW-BUFFER-END (1+ (BUFFER-PTR XP)))) (CHECK-SIZE XP BUFFER NEW-BUFFER-END) (IF (CHAR-MODE XP) (SETQ 
CHAR (HANDLE-CHAR-MODE XP CHAR))) (SETF (CHAR (BUFFER XP) (BUFFER-PTR XP)) CHAR) (SETF (BUFFER-PTR XP)
 NEW-BUFFER-END)))
(DEFUN FORCE-SOME-OUTPUT (XP) (ATTEMPT-TO-OUTPUT XP IL:NIL IL:NIL) (WHEN (> (BUFFER-PTR XP) (LINEL XP)
) (IL:* IL:\; "only if printing off end of line") (ATTEMPT-TO-OUTPUT XP T T)))
(DEFUN WRITE-STRING++ (STRING XP START END) (WHEN (> (BUFFER-PTR XP) (LINEL XP)) (FORCE-SOME-OUTPUT XP
)) (WRITE-STRING+++ STRING XP START END))
(DEFUN WRITE-STRING+++ (STRING XP START END) (LET ((NEW-BUFFER-END (+ (BUFFER-PTR XP) (- END START))))
 (CHECK-SIZE XP BUFFER NEW-BUFFER-END) (DO ((BUFFER (BUFFER XP)) (I (BUFFER-PTR XP) (1+ I)) (J START (
1+ J))) ((= J END)) (LET ((CHAR (CHAR STRING J))) (IF (CHAR-MODE XP) (SETQ CHAR (HANDLE-CHAR-MODE XP 
CHAR))) (SETF (CHAR BUFFER I) CHAR))) (SETF (BUFFER-PTR XP) NEW-BUFFER-END)))
(DEFUN PPRINT-TAB+ (KIND COLNUM COLINC XP) (LET ((INDENTED? IL:NIL) (RELATIVE? IL:NIL)) (CASE KIND (
:SECTION (SETQ INDENTED? T)) (:LINE-RELATIVE (SETQ RELATIVE? T)) (:SECTION-RELATIVE (SETQ INDENTED? T 
RELATIVE? T))) (LET* ((CURRENT (IF (NOT INDENTED?) (LP<-BP XP) (- (TP<-BP XP) (SECTION-START XP)))) (
NEW (IF (ZEROP COLINC) (IF RELATIVE? (+ CURRENT COLNUM) (MAX COLNUM CURRENT)) (COND (RELATIVE? (* 
COLINC (FLOOR (+ CURRENT COLNUM COLINC -1) COLINC))) ((> COLNUM CURRENT) COLNUM) (T (+ COLNUM (* 
COLINC (FLOOR (+ CURRENT (- COLNUM) COLINC) COLINC))))))) (LENGTH (- NEW CURRENT))) (WHEN (PLUSP 
LENGTH) (IF (CHAR-MODE XP) (HANDLE-CHAR-MODE XP #\Space)) (LET ((END (+ (BUFFER-PTR XP) LENGTH))) (
CHECK-SIZE XP BUFFER END) (FILL (BUFFER XP) #\Space :START (BUFFER-PTR XP) :END END) (SETF (BUFFER-PTR
 XP) END))))))
(DEFUN PPRINT-NEWLINE+ (KIND XP) (ENQUEUE XP :NEWLINE KIND) (DO ((PTR (QLEFT XP) (QNEXT PTR))) (IL:* 
IL:\; "find sections we are ending") ((NOT (< PTR (QRIGHT XP)))) (IL:* IL:\; "all but last") (WHEN (
AND (NULL (QEND XP PTR)) (NOT (> (DEPTH-IN-BLOCKS XP) (QDEPTH XP PTR))) (MEMBER (QTYPE XP PTR) (QUOTE 
(:NEWLINE :START-BLOCK)))) (SETF (QEND XP PTR) (- (QRIGHT XP) PTR)))) (SETF (SECTION-START XP) (TP<-BP
 XP)) (WHEN (AND (MEMBER KIND (QUOTE (:FRESH :UNCONDITIONAL))) (CHAR-MODE XP)) (HANDLE-CHAR-MODE XP 
#\Newline)) (WHEN (MEMBER KIND (QUOTE (:FRESH :UNCONDITIONAL :MANDATORY))) (ATTEMPT-TO-OUTPUT XP T 
IL:NIL)))
(DEFUN START-BLOCK (XP PREFIX-STRING ON-EACH-LINE? SUFFIX-STRING) (WHEN PREFIX-STRING (WRITE-STRING++ 
PREFIX-STRING XP 0 (LENGTH PREFIX-STRING))) (IF (AND (CHAR-MODE XP) ON-EACH-LINE?) (SETQ PREFIX-STRING
 (SUBSEQ (BUFFER XP) (- (BUFFER-PTR XP) (LENGTH PREFIX-STRING)) (BUFFER-PTR XP)))) (PUSH-BLOCK-STACK 
XP) (ENQUEUE XP :START-BLOCK IL:NIL (IF ON-EACH-LINE? (CONS SUFFIX-STRING PREFIX-STRING) SUFFIX-STRING
)) (INCF (DEPTH-IN-BLOCKS XP)) (IL:* IL:\; "must be after enqueue") (SETF (SECTION-START XP) (TP<-BP 
XP)))
(DEFUN END-BLOCK (XP SUFFIX) (UNLESS (EQ *ABBREVIATION-HAPPENED* (QUOTE *PRINT-LINES*)) (WHEN SUFFIX (
WRITE-STRING+ SUFFIX XP 0 (LENGTH SUFFIX))) (DECF (DEPTH-IN-BLOCKS XP)) (ENQUEUE XP :END-BLOCK IL:NIL 
SUFFIX) (DO ((PTR (QLEFT XP) (QNEXT PTR))) (IL:* IL:\; "looking for start of block we are ending") ((
NOT (< PTR (QRIGHT XP)))) (IL:* IL:\; "all but last") (WHEN (AND (= (DEPTH-IN-BLOCKS XP) (QDEPTH XP 
PTR)) (EQ (QTYPE XP PTR) :START-BLOCK) (NULL (QOFFSET XP PTR))) (SETF (QOFFSET XP PTR) (- (QRIGHT XP) 
PTR)) (RETURN IL:NIL))) (IL:* IL:\; "can only be 1") (POP-BLOCK-STACK XP)))
(DEFUN PPRINT-INDENT+ (KIND N XP) (ENQUEUE XP :IND KIND N))
(DEFMACRO MAYBE-TOO-LARGE (XP QENTRY) (IL:BQUOTE (LET ((LIMIT (LINEL (IL:\\\, XP)))) (WHEN (EQL (
LINE-LIMIT (IL:\\\, XP)) (LINE-NO (IL:\\\, XP))) (IL:* IL:\; "prevents suffix overflow") (DECF LIMIT 2
) (IL:* IL:|;;| "3 for \" ..\" minus 1 for space (heuristic)") (WHEN (NOT (MINUSP (PREFIX-STACK-PTR (
IL:\\\, XP)))) (DECF LIMIT (SUFFIX-PTR (IL:\\\, XP))))) (COND ((QEND (IL:\\\, XP) (IL:\\\, QENTRY)) (>
 (LP<-TP (IL:\\\, XP) (QPOS (IL:\\\, XP) (+ (IL:\\\, QENTRY) (QEND (IL:\\\, XP) (IL:\\\, QENTRY))))) 
LIMIT)) ((OR FORCE-NEWLINES? (> (LP<-BP (IL:\\\, XP)) LIMIT)) T) (T (RETURN IL:NIL))))))
(DEFMACRO MISERING? (XP) (IL:BQUOTE (AND *PRINT-MISER-WIDTH* (<= (- (LINEL (IL:\\\, XP)) (
INITIAL-PREFIX-PTR (IL:\\\, XP))) *PRINT-MISER-WIDTH*))))
(DEFUN ATTEMPT-TO-OUTPUT (XP FORCE-NEWLINES? FLUSH-OUT?) (DO IL:NIL ((> (QLEFT XP) (QRIGHT XP)) (SETF 
(QLEFT XP) 0) (SETF (QRIGHT XP) -7)) (IL:* IL:\; "saves shifting") (CASE (QTYPE XP (QLEFT XP)) (:IND (
UNLESS (MISERING? XP) (SET-INDENTATION-PREFIX XP (CASE (QKIND XP (QLEFT XP)) (:BLOCK (+ (
INITIAL-PREFIX-PTR XP) (QARG XP (QLEFT XP)))) (T (IL:* IL:\; ":current") (+ (LP<-TP XP (QPOS XP (QLEFT
 XP))) (QARG XP (QLEFT XP))))))) (SETF (QLEFT XP) (QNEXT (QLEFT XP)))) (:START-BLOCK (COND ((
MAYBE-TOO-LARGE XP (QLEFT XP)) (PUSH-PREFIX-STACK XP) (SETF (INITIAL-PREFIX-PTR XP) (PREFIX-PTR XP)) (
SET-INDENTATION-PREFIX XP (LP<-TP XP (QPOS XP (QLEFT XP)))) (LET ((ARG (QARG XP (QLEFT XP)))) (WHEN (
CONSP ARG) (SET-PREFIX XP (CDR ARG))) (SETF (INITIAL-PREFIX-PTR XP) (PREFIX-PTR XP)) (COND ((NOT (
LISTP ARG)) (SET-SUFFIX XP ARG)) ((CAR ARG) (SET-SUFFIX XP (CAR ARG))))) (SETF (SECTION-START-LINE XP)
 (LINE-NO XP))) (T (INCF (QLEFT XP) (QOFFSET XP (QLEFT XP))))) (SETF (QLEFT XP) (QNEXT (QLEFT XP)))) (
:END-BLOCK (POP-PREFIX-STACK XP) (SETF (QLEFT XP) (QNEXT (QLEFT XP)))) (T (IL:* IL:\; ":newline") (
WHEN (CASE (QKIND XP (QLEFT XP)) (:FRESH (NOT (ZEROP (LP<-BP XP)))) (:MISER (MISERING? XP)) (:FILL (OR
 (MISERING? XP) (> (LINE-NO XP) (SECTION-START-LINE XP)) (MAYBE-TOO-LARGE XP (QLEFT XP)))) (T T)) (IL:*
 IL:\; "(:linear :unconditional :mandatory) ") (OUTPUT-LINE XP (QLEFT XP)) (SETUP-FOR-NEXT-LINE XP (
QLEFT XP))) (SETF (QLEFT XP) (QNEXT (QLEFT XP)))))) (WHEN FLUSH-OUT? (FLUSH XP)))
(DEFUN FLUSH (XP) (UNLESS *LOCATING-CIRCULARITIES* (CL:WRITE-STRING (BUFFER XP) (BASE-STREAM XP) :END 
(BUFFER-PTR XP))) (INCF (BUFFER-OFFSET XP) (BUFFER-PTR XP)) (INCF (CHARPOS XP) (BUFFER-PTR XP)) (SETF 
(BUFFER-PTR XP) 0))
(DEFUN OUTPUT-LINE (XP QENTRY) (LET* ((OUT-POINT (BP<-TP XP (QPOS XP QENTRY))) (LAST-NON-BLANK (
POSITION #\Space (BUFFER XP) :TEST-NOT (FUNCTION CHAR=) :FROM-END T :END OUT-POINT)) (END (COND ((
MEMBER (QKIND XP QENTRY) (QUOTE (:FRESH :UNCONDITIONAL))) OUT-POINT) (LAST-NON-BLANK (1+ 
LAST-NON-BLANK)) (T 0))) (LINE-LIMIT-EXIT (AND (LINE-LIMIT XP) (NOT (> (LINE-LIMIT XP) (LINE-NO XP))))
)) (WHEN LINE-LIMIT-EXIT (SETF (BUFFER-PTR XP) END) (IL:* IL:\; "truncate pending output.") (
WRITE-STRING+++ " .." XP 0 3) (REVERSE-STRING-IN-PLACE (SUFFIX XP) 0 (SUFFIX-PTR XP)) (WRITE-STRING+++
 (SUFFIX XP) XP 0 (SUFFIX-PTR XP)) (SETF (QLEFT XP) (QNEXT (QRIGHT XP))) (SETQ *ABBREVIATION-HAPPENED*
 (QUOTE *PRINT-LINES*)) (THROW (QUOTE LINE-LIMIT-ABBREVIATION-EXIT) T)) (INCF (LINE-NO XP)) (UNLESS 
*LOCATING-CIRCULARITIES* (IL:* IL:|;;| "(CL:WRITE-LINE (BUFFER XP) (BASE-STREAM XP) :END END)") (IL:* 
IL:|;;| 
"The code below is equivalent assuming (BASE-STREAM XP) is not an XP-stream (I believe we can be sure this is the case)"
) (IL:WRITE-STRING* (BUFFER XP) (BASE-STREAM XP) 0 END) (IL:TERPRI (BASE-STREAM XP)))))
(DEFUN SETUP-FOR-NEXT-LINE (XP QENTRY) (LET* ((OUT-POINT (BP<-TP XP (QPOS XP QENTRY))) (PREFIX-END (
COND ((MEMBER (QKIND XP QENTRY) (QUOTE (:UNCONDITIONAL :FRESH))) (NON-BLANK-PREFIX-PTR XP)) (T (
PREFIX-PTR XP)))) (CHANGE (- PREFIX-END OUT-POINT))) (SETF (CHARPOS XP) 0) (IL:* IL:|;;| 
"(REPLACE (BUFFER XP) (BUFFER XP) :START1 PREFIX-END :START2 OUT-POINT :END2 (BUFFER-PTR XP))") (IL:* 
IL:|;;| "Equivalent code below; we could sure stand mega-optimizers on stuff like this...") (IF (PLUSP
 CHANGE) (PROGN (IL:* IL:\; "almost never happens") (CHECK-SIZE XP BUFFER (+ (BUFFER-PTR XP) CHANGE)) 
(REPLACE (BUFFER XP) (BUFFER XP) :START1 PREFIX-END :START2 OUT-POINT :END2 (BUFFER-PTR XP))) (DO ((S1
 PREFIX-END (INCF S1)) (S2 OUT-POINT (INCF S2)) (E2 (BUFFER-PTR XP)) (B (BUFFER XP))) ((IL:IGEQ S2 E2)
) (SETF (CHAR B S1) (CHAR B S2)))) (IL:* IL:|;;| "(REPLACE (BUFFER XP) (PREFIX XP) :END2 PREFIX-END)")
 (IL:* IL:|;;| "Equivalent code below; we could sure stand mega-optimizers on stuff like this...") (DO
 ((S1 0 (INCF S1)) (E2 PREFIX-END) (B (BUFFER XP)) (P (PREFIX XP))) ((IL:IGEQ S1 E2)) (SETF (CHAR B S1
) (CHAR P S1))) (INCF (BUFFER-PTR XP) CHANGE) (DECF (BUFFER-OFFSET XP) CHANGE) (WHEN (NOT (MEMBER (
QKIND XP QENTRY) (QUOTE (:UNCONDITIONAL :FRESH)))) (SETF (SECTION-START-LINE XP) (LINE-NO XP)))))
(DEFUN SET-INDENTATION-PREFIX (XP NEW-POSITION) (LET ((NEW-IND (MAX (NON-BLANK-PREFIX-PTR XP) 
NEW-POSITION))) (SETF (PREFIX-PTR XP) (INITIAL-PREFIX-PTR XP)) (CHECK-SIZE XP PREFIX NEW-IND) (WHEN (>
 NEW-IND (PREFIX-PTR XP)) (FILL (PREFIX XP) #\Space :START (PREFIX-PTR XP) :END NEW-IND)) (SETF (
PREFIX-PTR XP) NEW-IND)))
(DEFUN SET-PREFIX (XP PREFIX-STRING) (REPLACE (PREFIX XP) PREFIX-STRING :START1 (- (PREFIX-PTR XP) (
LENGTH PREFIX-STRING))) (SETF (NON-BLANK-PREFIX-PTR XP) (PREFIX-PTR XP)))
(DEFUN SET-SUFFIX (XP SUFFIX-STRING) (LET* ((END (LENGTH SUFFIX-STRING)) (NEW-END (+ (SUFFIX-PTR XP) 
END))) (CHECK-SIZE XP SUFFIX NEW-END) (DO ((I (1- NEW-END) (1- I)) (J 0 (1+ J))) ((= J END)) (SETF (
CHAR (SUFFIX XP) I) (CHAR SUFFIX-STRING J))) (SETF (SUFFIX-PTR XP) NEW-END)))
(DEFUN REVERSE-STRING-IN-PLACE (STRING START END) (DO ((I START (1+ I)) (J (1- END) (1- J))) ((NOT (< 
I J)) STRING) (LET ((C (CHAR STRING I))) (SETF (CHAR STRING I) (CHAR STRING J)) (SETF (CHAR STRING J) 
C))))
(DEFUN WRITE (OBJECT &REST PAIRS &KEY (STREAM *STANDARD-OUTPUT*) (ESCAPE *PRINT-ESCAPE*) (RADIX 
*PRINT-RADIX*) (BASE *PRINT-BASE*) (CIRCLE *PRINT-CIRCLE*) (PRETTY *PRINT-PRETTY*) (LEVEL 
*PRINT-LEVEL*) (LENGTH *PRINT-LENGTH*) (CASE *PRINT-CASE*) (GENSYM *PRINT-GENSYM*) (ARRAY 
*PRINT-ARRAY*) (PPRINT-DISPATCH *PRINT-PPRINT-DISPATCH*) (RIGHT-MARGIN *PRINT-RIGHT-MARGIN*) (LINES 
*PRINT-LINES*) (MISER-WIDTH *PRINT-MISER-WIDTH*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (LET ((
*PRINT-PPRINT-DISPATCH* PPRINT-DISPATCH) (*PRINT-RIGHT-MARGIN* RIGHT-MARGIN) (*PRINT-LINES* LINES) (
*PRINT-MISER-WIDTH* MISER-WIDTH)) (COND ((OR (XP-STRUCTURE-P STREAM) PRETTY) (LET ((*PRINT-ESCAPE* 
ESCAPE) (*PRINT-RADIX* RADIX) (*PRINT-BASE* BASE) (*PRINT-CIRCLE* CIRCLE) (*PRINT-PRETTY* PRETTY) (
*PRINT-LEVEL* LEVEL) (*PRINT-LENGTH* LENGTH) (*PRINT-CASE* CASE) (*PRINT-GENSYM* GENSYM) (
*PRINT-ARRAY* ARRAY)) (BASIC-WRITE OBJECT STREAM))) (T (REMF PAIRS :DISPATCH) (REMF PAIRS 
:RIGHT-MARGIN) (REMF PAIRS :LINES) (REMF PAIRS :MISER-WIDTH) (APPLY (FUNCTION CL:WRITE) OBJECT PAIRS))
)) OBJECT)
(DEFUN BASIC-WRITE (OBJECT STREAM) (COND ((XP-STRUCTURE-P STREAM) (WRITE+ OBJECT STREAM)) (
*PRINT-PRETTY* (MAYBE-INITIATE-XP-PRINTING (FUNCTION (LAMBDA (S O) (WRITE+ O S))) STREAM OBJECT)) (T (
CL:WRITE OBJECT :STREAM STREAM))))
(DEFUN MAYBE-INITIATE-XP-PRINTING (FN STREAM &REST ARGS) (IL:* IL:\; "Edited 10-Jul-92 11:51 by jrb:")
 (IF (XP-STRUCTURE-P STREAM) (APPLY FN STREAM ARGS) (LET ((*ABBREVIATION-HAPPENED* IL:NIL) (
*LOCATING-CIRCULARITIES* (IF *PRINT-CIRCLE* 0 IL:NIL)) (*CIRCULARITY-HASH-TABLE* (IF *PRINT-CIRCLE* (
GET-CIRCULARITY-HASH-TABLE) IL:NIL)) (*PARENTS* (WHEN (NOT *PRINT-SHARED*) (LIST IL:NIL))) (*RESULT* 
IL:NIL) (IL:\\THISFILELINELENGTH)) (DECLARE (SPECIAL IL:\\THISFILELINELENGTH)) (IL:* IL:|;;| 
"Common Lisp streams do not observe line length") (XP-PRINT FN (DECODE-STREAM-ARG STREAM) ARGS) (IF 
*CIRCULARITY-HASH-TABLE* (FREE-CIRCULARITY-HASH-TABLE *CIRCULARITY-HASH-TABLE*)) (WHEN 
*ABBREVIATION-HAPPENED* (SETQ *LAST-ABBREVIATED-PRINTING* (EVAL (IL:BQUOTE (FUNCTION (LAMBDA (
&OPTIONAL (STREAM (QUOTE (IL:\\\, STREAM)))) (LET ((*PACKAGE* (QUOTE (IL:\\\, *PACKAGE*)))) (APPLY (
FUNCTION MAYBE-INITIATE-XP-PRINTING) (QUOTE (IL:\\\, FN)) STREAM (QUOTE (IL:\\\, (COPY-LIST ARGS))))))
))))) *RESULT*)))
(DEFUN XP-PRINT (FN STREAM ARGS) (SETQ *RESULT* (DO-XP-PRINTING FN STREAM ARGS)) (WHEN 
*LOCATING-CIRCULARITIES* (SETQ *LOCATING-CIRCULARITIES* IL:NIL) (SETQ *ABBREVIATION-HAPPENED* IL:NIL) 
(SETQ *PARENTS* IL:NIL) (SETQ *RESULT* (DO-XP-PRINTING FN STREAM ARGS))))
(DEFUN DECODE-STREAM-ARG (STREAM) (COND ((NULL STREAM) *STANDARD-OUTPUT*) ((EQ STREAM T) *TERMINAL-IO*
) (T STREAM)))
(DEFUN DO-XP-PRINTING (FN STREAM ARGS) (LET ((XP (GET-PRETTY-PRINT-STREAM STREAM)) (*CURRENT-LEVEL* 0)
 (RESULT IL:NIL)) (CATCH (QUOTE LINE-LIMIT-ABBREVIATION-EXIT) (START-BLOCK XP IL:NIL IL:NIL IL:NIL) (
SETQ RESULT (APPLY FN XP ARGS)) (END-BLOCK XP IL:NIL)) (WHEN (AND *LOCATING-CIRCULARITIES* (ZEROP 
*LOCATING-CIRCULARITIES*) (IL:* IL:\; "No circularities.") (= (LINE-NO XP) 1) (IL:* IL:\; 
"Didn't suppress line.") (ZEROP (BUFFER-OFFSET XP))) (IL:* IL:\; "Didn't suppress partial line.") (
SETQ *LOCATING-CIRCULARITIES* IL:NIL)) (IL:* IL:\; "print what you have got.") (WHEN (CATCH (QUOTE 
LINE-LIMIT-ABBREVIATION-EXIT) (ATTEMPT-TO-OUTPUT XP IL:NIL T) IL:NIL) (ATTEMPT-TO-OUTPUT XP T T)) (
FREE-PRETTY-PRINT-STREAM XP) RESULT))
(DEFUN WRITE+ (OBJECT XP) (IL:* IL:\; "Edited  7-Jan-92 14:31 by jrb:") (LET ((*PARENTS* *PARENTS*)) (
UNLESS (AND *CIRCULARITY-HASH-TABLE* (EQ (CIRCULARITY-PROCESS XP OBJECT IL:NIL) :SUBSEQUENT)) (WHEN (
AND *CIRCULARITY-HASH-TABLE* (CONSP OBJECT)) (IL:* IL:|;;| 
"avoid possible double check in handle-logical-block.") (SETQ OBJECT (CONS (CAR OBJECT) (CDR OBJECT)))
) (LET ((PRINTER (IF *PRINT-PRETTY* (GET-PRINTER OBJECT *PRINT-PPRINT-DISPATCH*) IL:NIL)) TYPE) (COND 
(PRINTER (FUNCALL PRINTER XP OBJECT)) ((MAYBE-PRINT-FAST XP OBJECT)) ((AND *PRINT-PRETTY* (SYMBOLP (
SETQ TYPE (TYPE-OF OBJECT))) (SETQ PRINTER (GET TYPE (QUOTE CL::STRUCTURE-PRINTER))) (NOT (EQ PRINTER 
:NONE))) (FUNCALL PRINTER XP OBJECT)) ((AND *PRINT-PRETTY* *PRINT-ARRAY* (ARRAYP OBJECT) (NOT (STRINGP
 OBJECT)) (NOT (BIT-VECTOR-P OBJECT)) (NOT (STRUCTURE-TYPE-P (TYPE-OF OBJECT)))) (PRETTY-ARRAY XP 
OBJECT)) (T (IL:* IL:|;;| 
"OK, we're going to do it the new, strange way; just print it to XP, which SHOULD, through the magic of stream functions, hose the characters into the XP buffer"
) (NON-PRETTY-PRINT OBJECT XP)))))))
(DEFUN NON-PRETTY-PRINT (OBJECT S) (IL:* IL:|;;| 
"(CL:WRITE OBJECT :LEVEL (IF *PRINT-LEVEL* (- *PRINT-LEVEL* *CURRENT-LEVEL*)) :PRETTY NIL :STREAM S)")
 (LET (*PRINT-PRETTY* (*PRINT-LEVEL* (IF *PRINT-LEVEL* (- *PRINT-LEVEL* *CURRENT-LEVEL*)))) (IL:\\WRITE1
 OBJECT S)))
(DEFUN CIRCULARITY-PROCESS (XP OBJECT INTERIOR-CDR?) (UNLESS (OR (NUMBERP OBJECT) (CHARACTERP OBJECT) 
(AND (SYMBOLP OBJECT) (IL:* IL:\; "Reader takes care of sharing.") (OR (NULL *PRINT-GENSYM*) (
SYMBOL-PACKAGE OBJECT)))) (LET ((ID (GETHASH OBJECT *CIRCULARITY-HASH-TABLE*))) (IF 
*LOCATING-CIRCULARITIES* (COND ((NULL ID) (IL:* IL:\; "never seen before") (WHEN *PARENTS* (PUSH 
OBJECT *PARENTS*)) (SETF (GETHASH OBJECT *CIRCULARITY-HASH-TABLE*) 0) IL:NIL) ((ZEROP ID) (IL:* IL:\; 
"possible second occurrence") (COND ((OR (NULL *PARENTS*) (MEMBER OBJECT *PARENTS*)) (SETF (GETHASH 
OBJECT *CIRCULARITY-HASH-TABLE*) (INCF *LOCATING-CIRCULARITIES*)) :SUBSEQUENT) (T IL:NIL))) (T 
:SUBSEQUENT)) (IL:* IL:\; "third or later occurrence") (COND ((OR (NULL ID) (IL:* IL:\; 
"never seen before (note ~@* etc. conses)") (ZEROP ID)) (IL:* IL:\; "no duplicates") IL:NIL) ((PLUSP 
ID) (COND (INTERIOR-CDR? (DECF *CURRENT-LEVEL*) (WRITE-STRING++ ". #" XP 0 3)) (T (WRITE-CHAR++ #\# XP
))) (PRINT-FIXNUM XP ID) (WRITE-CHAR++ #\= XP) (SETF (GETHASH OBJECT *CIRCULARITY-HASH-TABLE*) (- ID))
 :FIRST) (T (IF INTERIOR-CDR? (WRITE-STRING++ ". #" XP 0 3) (WRITE-CHAR++ #\# XP)) (PRINT-FIXNUM XP (-
 ID)) (WRITE-CHAR++ #\# XP) :SUBSEQUENT))))))
(DEFUN MAYBE-PRINT-FAST (XP OBJECT) (COND ((SYMBOLP OBJECT) (IL:* IL:|;;| 
"The \"fast case\" for us is to print the atom to XP; our atom printer is tuned at a lower-than CLtL level so it should be fast enough.  Besides, it observes READTABLE-CASE, which the portable code does not; it could be made to, but why bother?"
) (NON-PRETTY-PRINT OBJECT XP) T) ((STRINGP OBJECT) (COND ((NULL *PRINT-ESCAPE*) (WRITE-STRING+ OBJECT
 XP 0 (LENGTH OBJECT)) T) ((EVERY (FUNCTION (LAMBDA (C) (NOT (OR (CHAR= C #\") (CHAR= C #\\))))) 
OBJECT) (WRITE-CHAR++ #\" XP) (WRITE-STRING+ OBJECT XP 0 (LENGTH OBJECT)) (WRITE-CHAR++ #\" XP) T))) (
(TYPEP OBJECT (QUOTE FIXNUM)) (WHEN (AND (NULL *PRINT-RADIX*) (= *PRINT-BASE* 10)) (WHEN (MINUSP 
OBJECT) (WRITE-CHAR++ #\- XP) (SETQ OBJECT (- OBJECT))) (PRINT-FIXNUM XP OBJECT) T))))
(DEFUN PRINT-FIXNUM (XP FIXNUM) (MULTIPLE-VALUE-BIND (DIGITS D) (TRUNCATE FIXNUM 10) (UNLESS (ZEROP 
DIGITS) (PRINT-FIXNUM XP DIGITS)) (WRITE-CHAR++ (CODE-CHAR (+ 48 D)) XP)))
(DEFUN NO-ESCAPES-NEEDED (S) (LET ((N (LENGTH S))) (AND (NOT (ZEROP N)) (LET ((C (SCHAR S 0))) (OR (
AND (ALPHA-CHAR-P C) (UPPER-CASE-P C)) (FIND C "*<>"))) (DO ((I 1 (1+ I))) ((= I N) T) (LET ((C (SCHAR
 S I))) (IF (NOT (OR (DIGIT-CHAR-P C) (AND (ALPHA-CHAR-P C) (UPPER-CASE-P C)) (FIND C "*+<>-"))) (
RETURN IL:NIL)))))))
(DEFUN PRINT (OBJECT &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (
TERPRI STREAM) (LET ((*PRINT-ESCAPE* T)) (BASIC-WRITE OBJECT STREAM)) (WRITE-CHAR #\Space STREAM) 
OBJECT)
(DEFUN PRIN1 (OBJECT &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (
LET ((*PRINT-ESCAPE* T)) (BASIC-WRITE OBJECT STREAM)) OBJECT)
(DEFUN PRINC (OBJECT &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (
LET ((*PRINT-ESCAPE* IL:NIL)) (BASIC-WRITE OBJECT STREAM)) OBJECT)
(DEFUN PPRINT (OBJECT &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (
TERPRI STREAM) (LET ((*PRINT-ESCAPE* T) (*PRINT-PRETTY* T)) (BASIC-WRITE OBJECT STREAM)) (VALUES))
(DEFUN WRITE-TO-STRING (OBJECT &REST PAIRS &KEY &ALLOW-OTHER-KEYS) (WITH-OUTPUT-TO-STRING (S) (APPLY (
FUNCTION WRITE) OBJECT :STREAM S PAIRS)))
(DEFUN PRINC-TO-STRING (OBJECT) (WITH-OUTPUT-TO-STRING (STREAM) (LET ((*PRINT-ESCAPE* IL:NIL)) (
BASIC-WRITE OBJECT STREAM))))
(DEFUN PRIN1-TO-STRING (OBJECT) (WITH-OUTPUT-TO-STRING (STREAM) (LET ((*PRINT-ESCAPE* T)) (BASIC-WRITE
 OBJECT STREAM))))
(DEFUN FORMAT (STREAM STRING-OR-FN &REST ARGS) (COND ((STRINGP STREAM) (CL:FORMAT STREAM "~A" (
WITH-OUTPUT-TO-STRING (STREAM) (APPLY (FUNCTION FORMAT) STREAM STRING-OR-FN ARGS))) IL:NIL) ((NULL 
STREAM) (WITH-OUTPUT-TO-STRING (STREAM) (APPLY (FUNCTION FORMAT) STREAM STRING-OR-FN ARGS))) (T (IF (
EQ STREAM T) (SETQ STREAM *STANDARD-OUTPUT*)) (WHEN (STRINGP STRING-OR-FN) (SETQ STRING-OR-FN (
PROCESS-FORMAT-STRING STRING-OR-FN IL:NIL))) (COND ((NOT (STRINGP STRING-OR-FN)) (APPLY STRING-OR-FN 
STREAM ARGS)) ((XP-STRUCTURE-P STREAM) (APPLY (FUNCTION USING-FORMAT) STREAM STRING-OR-FN ARGS)) (T (
APPLY (FUNCTION CL:FORMAT) STREAM STRING-OR-FN ARGS))) IL:NIL)))
(DEFVAR *FORMAT-STRING-CACHE* T)
(DEFUN PROCESS-FORMAT-STRING (STRING-OR-FN FORCE-FN?) (COND ((NOT (STRINGP STRING-OR-FN)) STRING-OR-FN
) (IL:* IL:\; "called from ~? too.") ((NOT *FORMAT-STRING-CACHE*) (MAYBE-COMPILE-FORMAT-STRING 
STRING-OR-FN FORCE-FN?)) (T (WHEN (NOT (HASH-TABLE-P *FORMAT-STRING-CACHE*)) (SETQ 
*FORMAT-STRING-CACHE* (MAKE-HASH-TABLE :TEST (FUNCTION EQ)))) (LET ((VALUE (GETHASH STRING-OR-FN 
*FORMAT-STRING-CACHE*))) (WHEN (OR (NOT VALUE) (AND FORCE-FN? (STRINGP VALUE))) (SETQ VALUE (
MAYBE-COMPILE-FORMAT-STRING STRING-OR-FN FORCE-FN?)) (SETF (GETHASH STRING-OR-FN *FORMAT-STRING-CACHE*
) VALUE)) VALUE))))
(DEFUN WRITE-LINE (STRING &OPTIONAL (STREAM *STANDARD-OUTPUT*) &KEY (START 0) (END (LENGTH STRING))) (
SETQ STREAM (DECODE-STREAM-ARG STREAM)) (IF (XP-STRUCTURE-P STREAM) (PROGN (WRITE-STRING+ STRING 
STREAM START END) (PPRINT-NEWLINE+ :UNCONDITIONAL STREAM)) (CL:WRITE-LINE STRING STREAM :START START 
:END END)) STRING)
(DEFUN WRITE-STRING (STRING &OPTIONAL (STREAM *STANDARD-OUTPUT*) &KEY (START 0) (END (LENGTH STRING)))
 (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (IF (XP-STRUCTURE-P STREAM) (WRITE-STRING+ STRING STREAM 
START END) (CL:WRITE-STRING STRING STREAM :START START :END END)) STRING)
(DEFUN WRITE-CHAR (CHAR &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM))
 (IF (XP-STRUCTURE-P STREAM) (WRITE-CHAR+ CHAR STREAM) (CL:WRITE-CHAR CHAR STREAM)) CHAR)
(DEFUN TERPRI (&OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (IF (
XP-STRUCTURE-P STREAM) (PPRINT-NEWLINE+ :UNCONDITIONAL STREAM) (CL:TERPRI STREAM)) IL:NIL)
(DEFUN FRESH-LINE (&OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (
COND ((XP-STRUCTURE-P STREAM) (ATTEMPT-TO-OUTPUT STREAM T T) (IL:* IL:\; "ok because we want newline")
 (WHEN (NOT (ZEROP (LP<-BP STREAM))) (PPRINT-NEWLINE+ :FRESH STREAM) T)) (T (CL:FRESH-LINE STREAM))))
(DEFUN FINISH-OUTPUT (&OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (
IF (XP-STRUCTURE-P STREAM) (ATTEMPT-TO-OUTPUT STREAM T T) (CL:FINISH-OUTPUT STREAM)) IL:NIL)
(DEFUN FORCE-OUTPUT (&OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (
IF (XP-STRUCTURE-P STREAM) (ATTEMPT-TO-OUTPUT STREAM T T) (CL:FORCE-OUTPUT STREAM)) IL:NIL)
(DEFUN CLEAR-OUTPUT (&OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG STREAM)) (
IF (XP-STRUCTURE-P STREAM) (LET ((*LOCATING-CIRCULARITIES* 0)) (IL:* IL:\; 
"hack to prevent visible output") (ATTEMPT-TO-OUTPUT STREAM T T)) (CL:CLEAR-OUTPUT STREAM)) IL:NIL)
(DEFMACRO DEFSTRUCT (NAME &BODY BODY) (LET* ((STRUCT-NAME (IF (CONSP NAME) (CAR NAME) NAME)) (PRINTER 
(CADR (SAFE-ASSOC :PRINT-FUNCTION NAME))) (XP-PRINT-FN (INTERN (CONCATENATE (QUOTE STRING) "PRINT-" (
STRING (PACKAGE-NAME (SYMBOL-PACKAGE STRUCT-NAME))) ":" (STRING STRUCT-NAME)) (FIND-PACKAGE "XP")))) (
COND (PRINTER (IL:BQUOTE (EVAL-WHEN (EVAL LOAD COMPILE) (CL:DEFSTRUCT (IL:\\\, NAME) (IL:\\\,@ BODY)) 
(DEFUN (IL:\\\, XP-PRINT-FN) (XP OBJ) (FUNCALL (FUNCTION (IL:\\\, PRINTER)) OBJ XP *CURRENT-LEVEL*)) (
SETF (GET (QUOTE (IL:\\\, STRUCT-NAME)) (QUOTE CL::STRUCTURE-PRINTER)) (FUNCTION (IL:\\\, XP-PRINT-FN)
)) (QUOTE (IL:\\\, (IF (CONSP NAME) (CAR NAME) NAME)))))) ((AND (NOT (SAFE-ASSOC :TYPE NAME)) (NOT (
SAFE-ASSOC :INCLUDE NAME))) (LET* ((CONC-NAME-SPEC (SAFE-ASSOC :CONC-NAME NAME)) (CONC-NAME (COND ((
NULL CONC-NAME-SPEC) (CONCATENATE (QUOTE STRING) (STRING STRUCT-NAME) "-")) ((NULL (CADR 
CONC-NAME-SPEC)) "") (T (STRING (CADR CONC-NAME-SPEC))))) (SLOTS (MAPCAR (FUNCTION (LAMBDA (X) (IF (
CONSP X) (CAR X) X))) BODY))) (IL:BQUOTE (EVAL-WHEN (EVAL LOAD COMPILE) (CL:DEFSTRUCT (IL:\\\, NAME) (
IL:\\\,@ BODY)) (DEFUN (IL:\\\, XP-PRINT-FN) (XP OBJ) (FUNCALL (FORMATTER 
"~@<#S(~;~W ~:I~@_~@{:~A ~W~^ ~:_~}~;)~:>") XP (QUOTE (IL:\\\, STRUCT-NAME)) (IL:\\\,@ (MAPCAN (
FUNCTION (LAMBDA (SLOT) (IL:BQUOTE ((IL:\\\, (STRING SLOT)) ((IL:\\\, (INTERN (CONCATENATE (QUOTE 
STRING) CONC-NAME (STRING SLOT)))) OBJ))))) SLOTS)))) (SETF (GET (QUOTE (IL:\\\, STRUCT-NAME)) (QUOTE 
CL::STRUCTURE-PRINTER)) (FUNCTION (IL:\\\, XP-PRINT-FN))) (QUOTE (IL:\\\, (IF (CONSP NAME) (CAR NAME) 
NAME))))))) (T (IL:BQUOTE (EVAL-WHEN (EVAL LOAD COMPILE) (SETF (GET (QUOTE (IL:\\\, STRUCT-NAME)) (
QUOTE CL::STRUCTURE-PRINTER)) :NONE) (CL:DEFSTRUCT (IL:\\\, NAME) (IL:\\\,@ BODY))))))))
(DEFUN SAFE-ASSOC (ITEM LIST) (DO ((L LIST (CDR L))) ((NOT (CONSP L)) IL:NIL) (IF (AND (CONSP (CAR L))
 (EQ (CAAR L) ITEM)) (RETURN (CAR L)))))
(DEFUN CL::STRUCTURE-WITH-USER-PRINTER (CL::XP CL::OBJ) (IL:* IL:\; "Edited  7-Jan-92 14:27 by jrb:") 
(FUNCALL (CL::PS-PRINT-FUNCTION (CL::PARSED-STRUCTURE (TYPE-OF CL::OBJ))) CL::OBJ CL::XP 
*CURRENT-LEVEL*))
(DEFUN CL::STRUCTURE-WITH-DEFAULT-PRINTER (&REST CL::STUFF-TO-PRINT) (IL:* IL:\; 
"Edited  7-Jan-92 14:27 by jrb:") (APPLY (FORMATTER "~@<#S(~;~W ~:I~@_~@{:~A ~W~^ ~:_~}~;)~:>") 
CL::STUFF-TO-PRINT))
(DEFMACRO PPRINT-LOGICAL-BLOCK ((STREAM-SYMBOL LIST &KEY (PREFIX IL:NIL) (PER-LINE-PREFIX IL:NIL) (
SUFFIX "")) &BODY BODY) (COND ((EQ STREAM-SYMBOL IL:NIL) (SETQ STREAM-SYMBOL (QUOTE *STANDARD-OUTPUT*)
)) ((EQ STREAM-SYMBOL T) (SETQ STREAM-SYMBOL (QUOTE *TERMINAL-IO*)))) (WHEN (NOT (SYMBOLP 
STREAM-SYMBOL)) (WARN "STREAM-SYMBOL arg ~S to PPRINT-LOGICAL-BLOCK is not a bindable symbol" 
STREAM-SYMBOL) (SETQ STREAM-SYMBOL (QUOTE *STANDARD-OUTPUT*))) (WHEN (AND PREFIX PER-LINE-PREFIX) (
WARN "prefix ~S and per-line-prefix ~S cannot both be specified in PPRINT-LOGICAL-BLOCK" PREFIX 
PER-LINE-PREFIX) (SETQ PER-LINE-PREFIX IL:NIL)) (IL:BQUOTE (MAYBE-INITIATE-XP-PRINTING (FUNCTION (
LAMBDA ((IL:\\\, STREAM-SYMBOL)) (LET ((+L (IL:\\\, LIST)) (+P (IL:\\\, (OR PREFIX PER-LINE-PREFIX "")
)) (+S (IL:\\\, SUFFIX))) (PPRINT-LOGICAL-BLOCK+ ((IL:\\\, STREAM-SYMBOL) +L +P +S (IL:\\\, (NOT (NULL
 PER-LINE-PREFIX))) T IL:NIL) (IL:\\\,@ BODY) IL:NIL)))) (DECODE-STREAM-ARG (IL:\\\, STREAM-SYMBOL))))
)
(DEFMACRO PPRINT-LOGICAL-BLOCK+ ((VAR ARGS PREFIX SUFFIX PER-LINE? CIRCLE-CHECK? ATSIGN?) &BODY BODY) 
(WHEN (AND CIRCLE-CHECK? ATSIGN?) (SETQ CIRCLE-CHECK? (QUOTE NOT-FIRST-P))) (IL:BQUOTE (LET ((
*CURRENT-LEVEL* (1+ *CURRENT-LEVEL*)) (*CURRENT-LENGTH* -1) (*PARENTS* *PARENTS*) (IL:\\\,@ (IF (AND 
CIRCLE-CHECK? ATSIGN?) (IL:BQUOTE ((NOT-FIRST-P (PLUSP *CURRENT-LENGTH*))))))) (UNLESS (
CHECK-BLOCK-ABBREVIATION (IL:\\\, VAR) (IL:\\\, ARGS) (IL:\\\, CIRCLE-CHECK?)) (BLOCK LOGICAL-BLOCK (
START-BLOCK (IL:\\\, VAR) (IL:\\\, PREFIX) (IL:\\\, PER-LINE?) (IL:\\\, SUFFIX)) (UNWIND-PROTECT (
MACROLET ((PPRINT-POP IL:NIL (IL:BQUOTE (PPRINT-POP+ (IL:\\\, (QUOTE (IL:\\\, ARGS))) (IL:\\\, (QUOTE 
(IL:\\\, VAR)))))) (PPRINT-EXIT-IF-LIST-EXHAUSTED IL:NIL (IL:BQUOTE (IF (NULL (IL:\\\, (QUOTE (IL:\\\,
 ARGS)))) (RETURN-FROM LOGICAL-BLOCK IL:NIL))))) (IL:\\\,@ BODY)) (END-BLOCK (IL:\\\, VAR) (IL:\\\, 
SUFFIX))))))))
(DEFUN PPRINT-NEWLINE (KIND &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (DECODE-STREAM-ARG 
STREAM)) (WHEN (NOT (MEMBER KIND (QUOTE (:LINEAR :MISER :FILL :MANDATORY)))) (ERROR 
"Invalid KIND argument ~A to PPRINT-NEWLINE" KIND)) (WHEN (XP-STRUCTURE-P STREAM) (PPRINT-NEWLINE+ 
KIND STREAM)) IL:NIL)
(DEFUN PPRINT-INDENT (RELATIVE-TO N &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (
DECODE-STREAM-ARG STREAM)) (WHEN (NOT (MEMBER RELATIVE-TO (QUOTE (:BLOCK :CURRENT)))) (ERROR 
"Invalid KIND argument ~A to PPRINT-INDENT" RELATIVE-TO)) (WHEN (XP-STRUCTURE-P STREAM) (
PPRINT-INDENT+ RELATIVE-TO N STREAM)) IL:NIL)
(DEFUN PPRINT-TAB (KIND COLNUM COLINC &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (SETQ STREAM (
DECODE-STREAM-ARG STREAM)) (WHEN (NOT (MEMBER KIND (QUOTE (:LINE :SECTION :LINE-RELATIVE 
:SECTION-RELATIVE)))) (ERROR "Invalid KIND argument ~A to PPRINT-TAB" KIND)) (WHEN (XP-STRUCTURE-P 
STREAM) (PPRINT-TAB+ KIND COLNUM COLINC STREAM)) IL:NIL)
(PROCLAIM (QUOTE (SPECIAL *STRING* *USED-ARGS* *USED-OUTER-ARGS* *USED-INITIAL* *GET-ARG-CAREFULLY* 
*INNER-END* *OUTER-END* *AT-TOP* *DEFAULT-PACKAGE*)))
(DEFVAR *FN-TABLE* (MAKE-HASH-TABLE) "used to access fns for commands")
(XCL:DEF-DEFINE-TYPE FORMAT-HANDLERS "XP pretty-printer FORMAT handlers" :UNDEFINER 
FORMAT-HANDLER-UNDEFINE)
(XCL:DEFDEFINER DEF-FORMAT-HANDLER FORMAT-HANDLERS (CHAR ARGS &BODY BODY) (IL:BQUOTE (EVAL-WHEN (EVAL 
LOAD COMPILE) (LET ((HANDLER (FUNCTION (LAMBDA (IL:\\\, ARGS) (IL:\\\,@ BODY))))) (SETF (GETHASH (
CHAR-UPCASE (IL:\\\, CHAR)) *FN-TABLE*) HANDLER) (SETF (GETHASH (CHAR-DOWNCASE (IL:\\\, CHAR)) 
*FN-TABLE*) HANDLER)))))
(DEFUN FORMAT-HANDLER-UNDEFINE (CHAR) (SETF (GETHASH (CHAR-UPCASE CHAR) *FN-TABLE*) IL:NIL (GETHASH (
CHAR-DOWNCASE CHAR) *FN-TABLE*) IL:NIL))
(DEFUN INITIAL IL:NIL (SETQ *USED-INITIAL* T) (QUOTE INIT))
(DEFMACRO BIND-INITIAL (&BODY CODE) (IL:BQUOTE (LET* ((*USED-INITIAL* IL:NIL) (BODY (PROGN (IL:\\\,@ 
CODE)))) (IF *USED-INITIAL* (MAKE-BINDING (QUOTE INIT) (ARGS) BODY) BODY))))
(DEFMACRO MAYBE-BIND-INITIAL (DOIT? &BODY CODE) (IL:* IL:|;;| 
"Hacked to use *USED-INITIAL* bound higher up in ~{ handler") (IL:BQUOTE (LET ((BODY (PROGN (IL:\\\,@ 
CODE)))) (IF (AND (IL:\\\, DOIT?) *USED-INITIAL*) (MAKE-BINDING (QUOTE INIT) (ARGS) BODY) BODY))))
(DEFUN ARGS IL:NIL (SETQ *USED-ARGS* T) (QUOTE ARGS))
(DEFMACRO BIND-ARGS (DOIT? VAL &BODY CODE) (IF (EQ DOIT? T) (IL:BQUOTE (LET* ((VAL (IL:\\\, VAL)) (
*USED-ARGS* IL:NIL) (BODY (PROGN (IL:\\\,@ CODE)))) (IF *USED-ARGS* (MAKE-BINDING (QUOTE ARGS) VAL 
BODY) (CONS VAL BODY)))) (IL:BQUOTE (FLET ((CODE IL:NIL (IL:\\\,@ CODE))) (IF (NOT (IL:\\\, DOIT?)) (
CODE) (IL:* IL:\; "important bindings not done if not doit?") (LET* ((VAL (IL:\\\, VAL)) (*USED-ARGS* 
IL:NIL) (BODY (CODE))) (IF *USED-ARGS* (MAKE-BINDING (QUOTE ARGS) VAL BODY) (CONS VAL BODY))))))))
(DEFUN OUTER-ARGS IL:NIL (SETQ *USED-OUTER-ARGS* T) (QUOTE OUTER-ARGS))
(DEFMACRO BIND-OUTER-ARGS (&BODY CODE) (IL:BQUOTE (LET* ((*USED-OUTER-ARGS* IL:NIL) (BODY (PROGN (
IL:\\\,@ CODE)))) (IF *USED-OUTER-ARGS* (MAKE-BINDING (QUOTE OUTER-ARGS) (ARGS) BODY) BODY))))
(DEFMACRO MAYBE-BIND (DOIT? VAR VAL &BODY CODE) (IL:BQUOTE (LET ((BODY (PROGN (IL:\\\,@ CODE)))) (IF (
IL:\\\, DOIT?) (MAKE-BINDING (IL:\\\, VAR) (IL:\\\, VAL) BODY) BODY))))
(DEFUN MAKE-BINDING (VAR VALUE BODY) (IL:BQUOTE ((LET (((IL:\\\, VAR) (IL:\\\, VALUE))) (IL:\\\,@ BODY
)))))
(DEFUN NUM-ARGS IL:NIL (IL:BQUOTE (LENGTH (IL:\\\, (ARGS)))))
(DEFUN GET-ARG IL:NIL (IF *GET-ARG-CAREFULLY* (IF *AT-TOP* (IL:BQUOTE (PPRINT-POP+TOP (IL:\\\, (ARGS))
 XP)) (IL:BQUOTE (PPRINT-POP+ (IL:\\\, (ARGS)) XP))) (IL:BQUOTE (POP (IL:\\\, (ARGS))))))
(DEFMACRO PPRINT-POP+ (ARGS XP) (IL:BQUOTE (IF (PPRINT-POP-CHECK+ (IL:\\\, ARGS) (IL:\\\, XP)) (
RETURN-FROM LOGICAL-BLOCK IL:NIL) (POP (IL:\\\, ARGS)))))
(DEFUN PPRINT-POP-CHECK+ (ARGS XP) (INCF *CURRENT-LENGTH*) (COND ((NOT (LISTP ARGS)) (IL:* IL:|;;| 
"must be first so supersedes length abbrev") (WRITE-STRING++ ". " XP 0 2) (WRITE+ ARGS XP) T) ((AND 
*PRINT-LENGTH* (IL:* IL:\; "must supersede circle check") (NOT (< *CURRENT-LENGTH* *PRINT-LENGTH*))) (
WRITE-STRING++ "..." XP 0 3) (SETQ *ABBREVIATION-HAPPENED* T) T) ((AND *CIRCULARITY-HASH-TABLE* (NOT (
ZEROP *CURRENT-LENGTH*))) (CASE (CIRCULARITY-PROCESS XP ARGS T) (:FIRST (IL:* IL:|;;| 
"note must inhibit rechecking of circularity for args.") (WRITE+ (CONS (CAR ARGS) (CDR ARGS)) XP) T) (
:SUBSEQUENT T) (T IL:NIL)))))
(DEFMACRO PPRINT-POP+TOP (ARGS XP) (IL:BQUOTE (IF (PPRINT-POP-CHECK+TOP (IL:\\\, ARGS) (IL:\\\, XP)) (
RETURN-FROM LOGICAL-BLOCK IL:NIL) (POP (IL:\\\, ARGS)))))
(DEFUN PPRINT-POP-CHECK+TOP (ARGS XP) (INCF *CURRENT-LENGTH*) (COND ((NOT (LISTP ARGS)) (IL:* IL:|;;| 
"must be first so supersedes length abbrev") (WRITE-STRING++ ". " XP 0 2) (WRITE+ ARGS XP) T) ((AND 
*PRINT-LENGTH* (IL:* IL:\; "must supersede circle check") (NOT (< *CURRENT-LENGTH* *PRINT-LENGTH*))) (
WRITE-STRING++ "..." XP 0 3) (SETQ *ABBREVIATION-HAPPENED* T) T)))
(DEFUN LITERAL (START END) (LET ((SUB-END IL:NIL) NEXT-NEWLINE (RESULT IL:NIL)) (LOOP (SETQ 
NEXT-NEWLINE (POSITION #\Newline *STRING* :START START :END END)) (SETQ SUB-END (IF NEXT-NEWLINE 
NEXT-NEWLINE END)) (WHEN (< START SUB-END) (PUSH (IF (= START (1- SUB-END)) (IL:BQUOTE (WRITE-CHAR++ (
IL:\\\, (AREF *STRING* START)) XP)) (IL:BQUOTE (WRITE-STRING++ (IL:\\\, (SUBSEQ *STRING* START SUB-END
)) XP (IL:\\\, 0) (IL:\\\, (- SUB-END START))))) RESULT)) (WHEN (NULL NEXT-NEWLINE) (RETURN IL:NIL)) (
PUSH (IL:BQUOTE (PPRINT-NEWLINE+ :UNCONDITIONAL XP)) RESULT) (SETQ START (1+ SUB-END))) (IF (NULL (CDR
 RESULT)) (CAR RESULT) (CONS (QUOTE PROGN) (NREVERSE RESULT)))))
(DEFUN FORMAT-STRING-READER (STREAM SUB-CHAR ARG) (DECLARE (IGNORE ARG)) (UNREAD-CHAR SUB-CHAR STREAM)
 (IL:BQUOTE (FORMATTER-IN-PACKAGE (IL:\\\, (READ STREAM)) (IL:\\\, (PACKAGE-NAME *PACKAGE*)))))
(DEFMACRO FORMATTER-IN-PACKAGE (STRING READER-PACKAGE) (FORMATTER-FN STRING READER-PACKAGE))
(DEFMACRO FORMATTER (STRING) (FORMATTER-FN STRING "USER"))
(DEFUN FORMATTER-FN (*STRING* *DEFAULT-PACKAGE*) (OR (CATCH :FORMAT-COMPILATION-ERROR (IL:BQUOTE (
FUNCTION (LAMBDA (S &REST ARGS) (APPLY (FUNCTION MAYBE-INITIATE-XP-PRINTING) (FUNCTION (LAMBDA (XP 
&REST ARGS) (IL:\\\,@ (BIND-INITIAL (IL:BQUOTE ((BLOCK TOP (IL:\\\,@ (LET ((*GET-ARG-CAREFULLY* IL:NIL
) (*AT-TOP* T) (*INNER-END* (QUOTE TOP)) (*OUTER-END* (QUOTE TOP))) (COMPILE-FORMAT 0 (LENGTH *STRING*
))))))))) (IF (IL:\\\, (ARGS)) (COPY-LIST (IL:\\\, (ARGS)))))) (IL:* IL:\; "needed by symbolics.") S 
ARGS))))) *STRING*))
(DEFUN MAYBE-COMPILE-FORMAT-STRING (STRING FORCE-FN?) (IF (NOT (OR FORCE-FN? (FANCY-DIRECTIVES-P 
STRING))) STRING (EVAL (IL:BQUOTE (FORMATTER (IL:\\\, STRING))))))
(DEFVAR *TESTING-ERRORS* IL:NIL "Used only when testing XP")
(DEFUN ERR (ID MSG I) (IF *TESTING-ERRORS* (THROW :TESTING-ERRORS (LIST ID I))) (WARN 
"XP: cannot compile format string ~%~A~%~S~%~V@T|" MSG *STRING* (1+ I)) (THROW 
:FORMAT-COMPILATION-ERROR IL:NIL))
(DEFUN POSITION-IN (SET START) (POSITION-IF (FUNCTION (LAMBDA (C) (FIND C SET))) *STRING* :START START
))
(DEFUN POSITION-NOT-IN (SET START) (POSITION-IF-NOT (FUNCTION (LAMBDA (C) (FIND C SET))) *STRING* 
:START START))
(DEFUN NEXT-DIRECTIVE1 (START END) (LET ((I (POSITION #\~ *STRING* :START START :END END)) J) (WHEN I 
(SETQ J (PARAMS-END (1+ I))) (WHEN (CHAR= (AREF *STRING* J) #\/) (SETQ J (POSITION #\/ *STRING* :START
 (1+ J) :END END)) (WHEN (NULL J) (ERR 3 "Matching / missing" (POSITION #\/ *STRING* :START START)))))
 (VALUES I J)))
(DEFUN PARAMS-END (START) (IL:* IL:\; "start points just after ~") (LET ((J START) (END (LENGTH 
*STRING*))) (LOOP (SETQ J (POSITION-NOT-IN "+-0123456789,Vv@" J)) (WHEN (NULL J) (ERR 1 
"missing directive" (1- START))) (WHEN (NOT (EQ (AREF *STRING* J) #\')) (RETURN J)) (INCF J) (IF (= J 
END) (ERR 2 "No character after '" (1- J))) (INCF J))))
(DEFUN DIRECTIVE-START (END) (IL:* IL:\; "end points at characters after params") (LOOP (SETQ END (
POSITION #\~ *STRING* :END END :FROM-END T)) (WHEN (OR (ZEROP END) (NOT (EQ (AREF *STRING* (1- END)) 
#\'))) (RETURN END)) (DECF END)))
(DEFUN NEXT-DIRECTIVE (START END) (LET (I J II K COUNT C CLOSE (PAIRS (QUOTE ((#\( . #\)) (#\[ . #\]) 
(#\< . #\>) (#\{ . #\}))))) (MULTIPLE-VALUE-SETQ (I J) (NEXT-DIRECTIVE1 START END)) (WHEN I (SETQ C (
AREF *STRING* J)) (SETQ CLOSE (CDR (ASSOC C PAIRS))) (WHEN CLOSE (SETQ K J COUNT 0) (LOOP (
MULTIPLE-VALUE-SETQ (II K) (NEXT-DIRECTIVE1 K END)) (WHEN (NULL II) (ERR 4 
"No matching close directive" J)) (WHEN (EQL (AREF *STRING* K) C) (INCF COUNT)) (WHEN (EQL (AREF 
*STRING* K) CLOSE) (DECF COUNT) (WHEN (MINUSP COUNT) (SETQ J K) (RETURN IL:NIL)))))) (VALUES C I J)))
(DEFUN CHUNK-UP (START END) (LET ((POSITIONS (LIST START)) (SPOT START)) (LOOP (MULTIPLE-VALUE-BIND (C
 I J) (NEXT-DIRECTIVE SPOT END) (DECLARE (IGNORE I)) (WHEN (NULL C) (RETURN (NREVERSE (CONS END 
POSITIONS)))) (WHEN (EQL C #\;) (PUSH (1+ J) POSITIONS)) (SETQ SPOT J)))))
(DEFUN FANCY-DIRECTIVES-P (*STRING*) (LET (I (J 0) (END (LENGTH *STRING*)) C) (LOOP (
MULTIPLE-VALUE-SETQ (I J) (NEXT-DIRECTIVE1 J END)) (WHEN (NOT I) (RETURN IL:NIL)) (SETQ C (AREF 
*STRING* J)) (WHEN (OR (FIND C "_Ii/Ww") (AND (FIND C ">Tt") (COLONP J))) (RETURN T)))))
(DEFUN NUM-ARGS-IN-ARGS (START &OPTIONAL (ERR IL:NIL)) (LET ((N 0) (I (1- START)) C) (LOOP (SETQ I (
POSITION-NOT-IN "+-0123456789," (1+ I))) (SETQ C (AREF *STRING* I)) (COND ((OR (CHAR= C #\V) (CHAR= C 
#\v)) (INCF N)) ((CHAR= C #\#) (WHEN ERR (ERR 21 "# not allowed in ~~<...~~> by (formatter \"...\")" 
START)) (RETURN IL:NIL)) ((CHAR= C #\') (INCF I)) (T (RETURN N))))))
(DEFUN COMPILE-FORMAT (START END) (LET ((RESULT IL:NIL)) (PROG (C I J FN) L (MULTIPLE-VALUE-SETQ (C I 
J) (NEXT-DIRECTIVE START END)) (WHEN (IF (NULL C) (< START END) (< START I)) (PUSH (LITERAL START (IF 
I I END)) RESULT)) (WHEN (NULL C) (RETURN (NREVERSE RESULT))) (WHEN (CHAR= C #\Newline) (
MULTIPLE-VALUE-BIND (COLON ATSIGN) (PARSE-PARAMS (1+ I) IL:NIL :NOCOLONATSIGN T) (WHEN ATSIGN (PUSH (
IL:BQUOTE (PPRINT-NEWLINE+ :UNCONDITIONAL XP)) RESULT)) (INCF J) (WHEN (NOT COLON) (SETQ J (
POSITION-IF-NOT (FUNCTION (LAMBDA (C) (OR (CHAR= C #\Tab) (CHAR= C #\Space)))) *STRING* :START J :END 
END)) (WHEN (NULL J) (SETQ J END))) (SETQ START J) (GO L))) (SETQ FN (GETHASH C *FN-TABLE*)) (WHEN (
NULL FN) (ERR 5 "Unknown format directive" J)) (INCF J) (PUSH (FUNCALL FN (1+ I) J) RESULT) (SETQ 
START J) (GO L))))
(DEFUN PARSE-PARAMS (START DEFAULTS &KEY (MAX (LENGTH DEFAULTS)) (NOCOLON IL:NIL) (NOATSIGN IL:NIL) (
NOCOLONATSIGN IL:NIL)) (LET ((COLON IL:NIL) (ATSIGN IL:NIL) (PARAMS IL:NIL) (I START) J C) (LOOP (SETQ
 C (AREF *STRING* I)) (COND ((OR (CHAR= C #\V) (CHAR= C #\v)) (PUSH (GET-ARG) PARAMS) (INCF I)) ((
CHAR= C #\#) (PUSH (NUM-ARGS) PARAMS) (INCF I)) ((CHAR= C #\') (INCF I) (PUSH (AREF *STRING* I) PARAMS
) (INCF I)) ((CHAR= C #\,) (PUSH IL:NIL PARAMS)) (T (SETQ J (POSITION-NOT-IN "+-0123456789" I)) (IF (=
 I J) (RETURN IL:NIL)) (PUSH (PARSE-INTEGER *STRING* :START I :END J :RADIX 10) PARAMS) (SETQ I J))) (
IF (CHAR= (AREF *STRING* I) #\,) (INCF I) (RETURN IL:NIL))) (SETQ PARAMS (NREVERSE PARAMS)) (DO ((PS 
PARAMS (CDR PS)) (DS DEFAULTS (CDR DS)) (NPS IL:NIL)) ((NULL DS) (SETQ PARAMS (NRECONC NPS PS))) (PUSH
 (COND ((OR (NULL PS) (NULL (CAR PS))) (CAR DS)) ((NOT (CONSP (CAR PS))) (CAR PS)) (T (IL:BQUOTE (COND
 ((IL:\\\, (CAR PS))) (T (IL:\\\, (CAR DS))))))) NPS)) (IF (AND MAX (< MAX (LENGTH PARAMS))) (ERR 6 
"Too many parameters" I)) (LOOP (SETQ C (AREF *STRING* I)) (COND ((CHAR= C #\:) (IF COLON (ERR 7 
"Two colons specified" I)) (SETQ COLON T)) ((CHAR= C #\@) (IF ATSIGN (ERR 8 "Two atsigns specified" I)
) (SETQ ATSIGN T)) (T (RETURN IL:NIL))) (INCF I)) (IF (AND COLON NOCOLON) (ERR 9 "Colon not permitted"
 I)) (IF (AND ATSIGN NOATSIGN) (ERR 10 "Atsign not permitted" I)) (IF (AND COLON ATSIGN NOCOLONATSIGN)
 (ERR 11 "Colon and atsign together not permitted" I)) (VALUES COLON ATSIGN PARAMS)))
(DEFUN COLONP (J) (IL:* IL:\; "j points to directive name") (OR (EQL (AREF *STRING* (1- J)) #\:) (AND 
(EQL (AREF *STRING* (1- J)) #\@) (EQL (AREF *STRING* (- J 2)) #\:))))
(DEFUN ATSIGNP (J) (IL:* IL:\; "j points to directive name") (OR (EQL (AREF *STRING* (1- J)) #\@) (AND
 (EQL (AREF *STRING* (1- J)) #\:) (EQL (AREF *STRING* (- J 2)) #\@))))
(DEFVAR *FAST-FORMATTER-SLASH-CALL* (QUOTE (PPRINT-LINEAR PPRINT-FILL PPRINT-TABULAR MAYBELAB 
BLOCK-LIKE BIND-LIST)) "Functions to make hard links to in ~/.../ FORMATTER code.")
(DEFVAR *FORMATTER-SLASH-PARANOIA* T 
"If non-NIL, formatter calls to ~/.../ functions check for forms whose CAR is on *formatter-slash-paranoia-list*; those forms do NOT call the ~/.../ function but instead get printed by WRITE+"
)
(DEFVAR *FORMATTER-SLASH-PARANOIA-LIST* (QUOTE (IL:BQUOTE IL:\\\, IL:\\\,@)) 
"Initially paranoia is only applied to backquote operators.")
(DEF-FORMAT-HANDLER #\/ (START END) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START 
IL:NIL :MAX IL:NIL) (LET* ((WHOLE-NAME-START (1+ (PARAMS-END START))) (COLON-POS (POSITION #\: 
*STRING* :START WHOLE-NAME-START :END (1- END))) (PKG (FIND-PACKAGE (IF COLON-POS (STRING-UPCASE (
SUBSEQ *STRING* WHOLE-NAME-START COLON-POS)) *DEFAULT-PACKAGE*))) (NAME-START (COND ((NULL COLON-POS) 
WHOLE-NAME-START) ((AND (< COLON-POS (1- END)) (CHAR= #\: (AREF *STRING* (1+ COLON-POS)))) (+ 
COLON-POS 2)) (T (1+ COLON-POS)))) (FN (INTERN (STRING-UPCASE (SUBSEQ *STRING* NAME-START (1- END))) 
PKG)) (FN-NAME (IF (MEMBER FN *FAST-FORMATTER-SLASH-CALL*) (IL:BQUOTE (FUNCTION (IL:\\\, FN))) (
IL:BQUOTE (SYMBOL-FUNCTION (QUOTE (IL:\\\, FN))))))) (IL:* IL:|;;;| "Hacks of interest below:") (IL:* 
IL:|;;;| 
"*FAST-FORMATTER-SLASH-CALL* makes ~/.../ calls to functions on that list turn into #'... rather than (SYMBOL-FUNCTION '...) which should improve performance a bit."
) (IL:* IL:|;;;| 
"*FORMATTER-SLASH-PARANOIA* tells ~/.../ to check for forms whose CAR is on *FORMATTER-SLASH-PARANOIA-LIST*, and to NOT call the ... function for those.  This is currently used to catch our back-quote wrappers."
) (IF *FORMATTER-SLASH-PARANOIA* (IF (NOT (FIND-IF (FUNCTION CONSP) PARAMS)) (IL:BQUOTE (LET ((
LOCAL-ARG (IL:\\\, (GET-ARG)))) (IF (AND (CONSP LOCAL-ARG) (MEMBER (CAR LOCAL-ARG) 
*FORMATTER-SLASH-PARANOIA-LIST*)) (WRITE+ LOCAL-ARG XP) (FUNCALL (IL:\\\, FN-NAME) XP LOCAL-ARG (IL:\\\,
 COLON) (IL:\\\, ATSIGN) (IL:\\\,@ PARAMS))))) (LET ((VARS (MAPCAR (FUNCTION (LAMBDA (ARG) (DECLARE (
IGNORE ARG)) (GENTEMP))) PARAMS))) (IL:BQUOTE (LET ((IL:\\\,@ (MAPCAR (FUNCTION LIST) VARS PARAMS)) (
LOCAL-ARG (IL:\\\, (GET-ARG)))) (IF (AND (CONSP LOCAL-ARG) (MEMBER (CAR LOCAL-ARG) 
*FORMATTER-SLASH-PARANOIA-LIST*)) (WRITE+ LOCAL-ARG XP) (FUNCALL (IL:\\\, FN-NAME) XP LOCAL-ARG (IL:\\\,
 COLON) (IL:\\\, ATSIGN) (IL:\\\,@ VARS))))))) (IF (NOT (FIND-IF (FUNCTION CONSP) PARAMS)) (IL:BQUOTE 
(FUNCALL (IL:\\\, FN-NAME) XP (IL:\\\, (GET-ARG)) (IL:\\\, COLON) (IL:\\\, ATSIGN) (IL:\\\,@ PARAMS)))
 (LET ((VARS (MAPCAR (FUNCTION (LAMBDA (ARG) (DECLARE (IGNORE ARG)) (GENTEMP))) PARAMS))) (IL:BQUOTE (
LET (IL:\\\, (MAPCAR (FUNCTION LIST) VARS PARAMS)) (FUNCALL (IL:\\\, FN-NAME) XP (IL:\\\, (GET-ARG)) (
IL:\\\, COLON) (IL:\\\, ATSIGN) (IL:\\\,@ VARS))))))))))
(DEF-FORMAT-HANDLER #\A (START END) (IF (NOT (= END (1+ START))) (SIMPLE-DIRECTIVE START END) (IL:BQUOTE
 (LET ((*PRINT-ESCAPE* IL:NIL)) (WRITE+ (IL:\\\, (GET-ARG)) XP)))))
(DEF-FORMAT-HANDLER #\S (START END) (IF (NOT (= END (1+ START))) (SIMPLE-DIRECTIVE START END) (IL:BQUOTE
 (LET ((*PRINT-ESCAPE* T)) (WRITE+ (IL:\\\, (GET-ARG)) XP)))))
(DEF-FORMAT-HANDLER #\D (START END) (SIMPLE-DIRECTIVE START END))
(DEF-FORMAT-HANDLER #\B (START END) (SIMPLE-DIRECTIVE START END))
(DEF-FORMAT-HANDLER #\O (START END) (SIMPLE-DIRECTIVE START END))
(DEF-FORMAT-HANDLER #\X (START END) (SIMPLE-DIRECTIVE START END))
(DEF-FORMAT-HANDLER #\R (START END) (SIMPLE-DIRECTIVE START END))
(DEF-FORMAT-HANDLER #\C (START END) (SIMPLE-DIRECTIVE START END))
(DEF-FORMAT-HANDLER #\F (START END) (SIMPLE-DIRECTIVE START END))
(DEF-FORMAT-HANDLER #\E (START END) (SIMPLE-DIRECTIVE START END))
(DEF-FORMAT-HANDLER #\G (START END) (SIMPLE-DIRECTIVE START END))
(DEF-FORMAT-HANDLER #\$ (START END) (SIMPLE-DIRECTIVE START END))
(DEFUN SIMPLE-DIRECTIVE (START END) (LET ((N (NUM-ARGS-IN-ARGS START))) (IF N (IL:BQUOTE (USING-FORMAT
 XP (IL:\\\, (SUBSEQ *STRING* (1- START) END)) (IL:\\\,@ (COPY-TREE (MAKE-LIST (1+ N) :INITIAL-ELEMENT
 (GET-ARG)))))) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START IL:NIL :MAX 8) (LET* ((
ARG-STR (SUBSEQ "v,v,v,v,v,v,v,v" 0 (MAX 0 (1- (* 2 (LENGTH PARAMS)))))) (STR (CONCATENATE (QUOTE 
STRING) "~" ARG-STR (IF COLON ":" "") (IF ATSIGN "@" "") (SUBSEQ *STRING* (1- END) END)))) (IL:BQUOTE 
(USING-FORMAT XP (IL:\\\, STR) (IL:\\\,@ PARAMS) (IL:\\\, (GET-ARG)))))))))
(DEFUN USING-FORMAT (XP STRING &REST ARGS) (IL:* IL:|;;| 
"The code below is bogus in our merged world; we can just print the damned thing.  The clear intent of this code is to non-pretty-print something; the way we're doing it, it should be sufficient to turn *print-pretty* off"
) (IL:* IL:|;;| 
"(LET ((RESULT (APPLY #'CL:FORMAT NIL STRING ARGS))) (WRITE-STRING+ RESULT XP 0 (LENGTH RESULT)))") (
IL:* IL:|;;| 
"This should \"really\" be a macro, except that it is APPLYed several places in XP.  I suspect an optimizer is in order here..."
) (LET (*PRINT-PRETTY*) (APPLY (FUNCTION CL:FORMAT) XP STRING ARGS)))
(DEF-FORMAT-HANDLER #\P (START END) (DECLARE (IGNORE END)) (MULTIPLE-VALUE-BIND (COLON ATSIGN) (
PARSE-PARAMS START IL:NIL) (LET ((ARG (IF COLON (IL:BQUOTE (CAR (BACKUP-IN-LIST 1 (IL:\\\, (INITIAL)) 
(IL:\\\, (ARGS))))) (GET-ARG)))) (IF ATSIGN (IL:BQUOTE (IF (NOT (EQL (IL:\\\, ARG) 1)) (WRITE-STRING++
 "ies" XP 0 3) (WRITE-CHAR++ #\y XP))) (IL:BQUOTE (IF (NOT (EQL (IL:\\\, ARG) 1)) (WRITE-CHAR++ #\s XP
)))))))
(DEF-FORMAT-HANDLER #\% (START END) (DECLARE (IGNORE END)) (MULTIPLE-NEWLINES START :UNCONDITIONAL))
(DEF-FORMAT-HANDLER #\& (START END) (DECLARE (IGNORE END)) (MULTIPLE-NEWLINES START :FRESH))
(DEFUN MULTIPLE-NEWLINES (START KIND) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START (
QUOTE (1)) :NOCOLON T :NOATSIGN T) (DECLARE (IGNORE COLON ATSIGN)) (IF (EQL (CAR PARAMS) 1) (IL:BQUOTE
 (PPRINT-NEWLINE+ (IL:\\\, KIND) XP)) (IL:BQUOTE (MULTIPLE-NEWLINES1 XP (IL:\\\, KIND) (IL:\\\, (CAR 
PARAMS)))))))
(DEFUN MULTIPLE-NEWLINES1 (XP KIND NUM) (DO ((N NUM (1- N))) ((NOT (PLUSP N))) (PPRINT-NEWLINE+ KIND 
XP) (SETQ KIND :UNCONDITIONAL)))
(DEF-FORMAT-HANDLER #\| (START END) (DECLARE (IGNORE END)) (MULTIPLE-CHARS START #\Page))
(DEF-FORMAT-HANDLER #\~ (START END) (DECLARE (IGNORE END)) (MULTIPLE-CHARS START #\~))
(DEFUN MULTIPLE-CHARS (START CHAR) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START (
QUOTE (1)) :NOCOLON T :NOATSIGN T) (DECLARE (IGNORE COLON ATSIGN)) (IF (EQL (CAR PARAMS) 1) (IL:BQUOTE
 (WRITE-CHAR++ (IL:\\\, CHAR) XP)) (IL:BQUOTE (MULTIPLE-CHARS1 XP (IL:\\\, (CAR PARAMS)) (IL:\\\, CHAR
))))))
(DEFUN MULTIPLE-CHARS1 (XP NUM CHAR) (DO ((N NUM (1- N))) ((NOT (PLUSP N))) (WRITE-CHAR++ CHAR XP)))
(DEF-FORMAT-HANDLER #\T (START END) (DECLARE (IGNORE END)) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) 
(PARSE-PARAMS START (QUOTE (1 1))) (IL:BQUOTE (PPRINT-TAB+ (IL:\\\, (IF COLON (IF ATSIGN 
:SECTION-RELATIVE :SECTION) (IF ATSIGN :LINE-RELATIVE :LINE))) (IL:\\\, (POP PARAMS)) (IL:\\\, (POP 
PARAMS)) XP))))
(DEF-FORMAT-HANDLER #\* (START END) (DECLARE (IGNORE END)) (IF (ATSIGNP (PARAMS-END START)) (
MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START (QUOTE (0)) :NOCOLON T) (DECLARE (IGNORE
 COLON ATSIGN)) (IL:BQUOTE (SETQ ARGS (BACKUP-TO (IL:\\\, (CAR PARAMS)) (IL:\\\, (INITIAL)) (IL:\\\, (
ARGS)))))) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START (QUOTE (1))) (DECLARE (
IGNORE ATSIGN)) (IL:BQUOTE (SETQ ARGS (IL:\\\, (IF COLON (IL:BQUOTE (BACKUP-IN-LIST (IL:\\\, (CAR 
PARAMS)) (IL:\\\, (INITIAL)) (IL:\\\, (ARGS)))) (IL:BQUOTE (NTHCDR (IL:\\\, (CAR PARAMS)) (IL:\\\, (
ARGS)))))))))))
(DEFUN BACKUP-IN-LIST (NUM LIST SOME-TAIL) (BACKUP-TO (- (TAIL-POS LIST SOME-TAIL) NUM) LIST SOME-TAIL
))
(DEFUN BACKUP-TO (NUM LIST SOME-TAIL) (IF (NOT *CIRCULARITY-HASH-TABLE*) (NTHCDR NUM LIST) (
MULTIPLE-VALUE-BIND (POS SHARE) (TAIL-POS LIST SOME-TAIL) (DECLARE (IGNORE POS)) (IF (NOT (< NUM SHARE
)) (NTHCDR NUM LIST) (DO ((L (NTHCDR NUM LIST) (CDR L)) (N (- SHARE NUM) (1- N)) (R IL:NIL (CONS (CAR 
L) R))) ((ZEROP N) (NRECONC R L)))))))
(DEFUN TAIL-POS (LIST SOME-TAIL) (BLOCK OUTER (DO ((N 0 (1+ N)) (L LIST (CDR L))) (IL:NIL) (DO ((M N (
1- M)) (ST SOME-TAIL (CDR ST))) (IL:NIL) (IF (MINUSP M) (RETURN IL:NIL)) (IF (EQ ST L) (RETURN-FROM 
OUTER (VALUES M N)))))))
(DEF-FORMAT-HANDLER #\? (START END) (DECLARE (IGNORE END)) (MULTIPLE-VALUE-BIND (COLON ATSIGN) (
PARSE-PARAMS START IL:NIL :NOCOLON T) (DECLARE (IGNORE COLON)) (IF (NOT ATSIGN) (IL:BQUOTE (APPLY (
FUNCTION FORMAT) XP (IL:\\\, (GET-ARG)) (IL:\\\, (GET-ARG)))) (IL:BQUOTE (LET ((FN (
PROCESS-FORMAT-STRING (IL:\\\, (GET-ARG)) T))) (SETQ ARGS (APPLY FN XP (IL:\\\, (ARGS)))))))))
(DEF-FORMAT-HANDLER #\^ (START END) (DECLARE (IGNORE END)) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) 
(PARSE-PARAMS START IL:NIL :MAX 3 :NOATSIGN T) (DECLARE (IGNORE ATSIGN)) (IL:BQUOTE (IF (IL:\\\, (COND
 ((NULL PARAMS) (IL:BQUOTE (NULL (IL:\\\, (IF COLON (IL:BQUOTE (CDR (IL:\\\, (OUTER-ARGS)))) (ARGS))))
)) (T (IL:BQUOTE (DO-COMPLEX-^-TEST (IL:\\\,@ PARAMS)))))) (RETURN-FROM (IL:\\\, (IF COLON *OUTER-END*
 *INNER-END*)) IL:NIL)))))
(DEFUN DO-COMPLEX-^-TEST (A1 &OPTIONAL (A2 IL:NIL) (A3 IL:NIL)) (COND (A3 (AND (<= A1 A2) (<= A2 A3)))
 (A2 (= A1 A2)) (T (= 0 A1))))
(DEF-FORMAT-HANDLER #\[ (START END) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START 
IL:NIL :MAX 1 :NOCOLONATSIGN T) (SETQ START (1+ (PARAMS-END START))) (LET* ((CHUNKS (CHUNK-UP START 
END)) (INNARDS (DO ((NS CHUNKS (CDR NS)) (MS (CDR CHUNKS) (CDR MS)) (RESULT IL:NIL)) ((NULL MS) (
RETURN (NREVERSE RESULT))) (PUSH (COMPILE-FORMAT (CAR NS) (DIRECTIVE-START (CAR MS))) RESULT)))) (COND
 (COLON (WHEN (NOT (= (LENGTH INNARDS) 2)) (ERR 13 "Wrong number of clauses in ~~:[...~~]" (1- START))
) (IL:BQUOTE (COND ((NULL (IL:\\\, (GET-ARG))) (IL:\\\,@ (CAR INNARDS))) (T (IL:\\\,@ (CADR INNARDS)))
))) (ATSIGN (WHEN (NOT (= (LENGTH INNARDS) 1)) (ERR 14 "Too many clauses in ~~@[...~~]" (1- START))) (
IL:BQUOTE (COND ((CAR ARGS) (IL:\\\,@ (CAR INNARDS))) (T (IL:\\\, (GET-ARG)))))) (T (LET* ((J -1) (LEN
 (- (LENGTH CHUNKS) 2)) (ELSE? (COLONP (1- (NTH LEN CHUNKS))))) (IL:BQUOTE (CASE (IL:\\\, (IF PARAMS (
CAR PARAMS) (GET-ARG))) (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (UNIT) (INCF J) (IL:BQUOTE ((IL:\\\, (IF (
AND ELSE? (= J LEN)) T J)) (IL:\\\,@ UNIT))))) INNARDS))))))))))
(DEF-FORMAT-HANDLER #\( (START END) (MULTIPLE-VALUE-BIND (COLON ATSIGN) (PARSE-PARAMS START IL:NIL) (
SETQ START (1+ (PARAMS-END START))) (SETQ END (DIRECTIVE-START END)) (IL:BQUOTE (PROGN (PUSH-CHAR-MODE
 XP (IL:\\\, (COND ((AND COLON ATSIGN) :UP) (COLON :CAP1) (ATSIGN :CAP0) (T :DOWN)))) (IL:\\\,@ (
COMPILE-FORMAT START END)) (POP-CHAR-MODE XP)))))
(DEF-FORMAT-HANDLER #\; (START END) (DECLARE (IGNORE START)) (ERR 15 "~~; appears out of context" (1- 
END)))
(DEF-FORMAT-HANDLER #\] (START END) (DECLARE (IGNORE START)) (ERR 16 "Unmatched closing directive" (1-
 END)))
(DEF-FORMAT-HANDLER #\) (START END) (DECLARE (IGNORE START)) (ERR 17 "Unmatched closing directive" (1-
 END)))
(DEF-FORMAT-HANDLER #\> (START END) (DECLARE (IGNORE START)) (ERR 18 "Unmatched closing directive" (1-
 END)))
(DEF-FORMAT-HANDLER #\} (START END) (DECLARE (IGNORE START)) (ERR 19 "Unmatched closing directive" (1-
 END)))
(DEF-FORMAT-HANDLER #\{ (START END) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) (PARSE-PARAMS START (
QUOTE (-1)) :MAX 1) (LET* ((FORCE-ONCE (COLONP (1- END))) (N (CAR PARAMS)) (BOUNDED (NOT (EQL N -1))) 
(*USED-INITIAL* IL:NIL)) (SETQ START (1+ (PARAMS-END START))) (SETQ END (DIRECTIVE-START END)) (CAR (
MAYBE-BIND BOUNDED (QUOTE N) N (IL:* IL:\; "must be outermost if is V or #") (MAYBE-BIND (NOT (> END 
START)) (QUOTE FN) (IL:* IL:\; "must be second") (IL:BQUOTE (PROCESS-FORMAT-STRING (IL:\\\, (GET-ARG))
 T)) (BIND-ARGS (NOT ATSIGN) (GET-ARG) (IL:BQUOTE ((IL:\\\,@ (MAYBE-BIND-INITIAL (OR (NOT ATSIGN) (NOT
 COLON)) (IL:BQUOTE ((PROG IL:NIL (IL:\\\,@ (IF FORCE-ONCE (QUOTE ((GO S))))) L (IF (NULL (IL:\\\, (
ARGS))) (RETURN IL:NIL)) (IL:\\\,@ (IF FORCE-ONCE (QUOTE (S)))) (IL:\\\,@ (IF BOUNDED (QUOTE ((IF (= N
 0) (RETURN IL:NIL) (DECF N)))))) (IL:\\\,@ (BIND-OUTER-ARGS (BIND-ARGS COLON (GET-ARG) (IL:BQUOTE ((
IL:\\\,@ (MAYBE-BIND-INITIAL COLON (LET ((*GET-ARG-CAREFULLY* (AND *GET-ARG-CAREFULLY* ATSIGN)) (
*AT-TOP* (AND *AT-TOP* ATSIGN)) (*OUTER-END* IL:NIL) (*INNER-END* IL:NIL)) (IF (NOT COLON) (IF (NOT (>
 END START)) (IL:BQUOTE ((SETQ ARGS (APPLY FN XP (IL:\\\, (ARGS)))))) (COMPILE-FORMAT START END)) (LET
 ((*INNER-END* (QUOTE INNER))) (IL:BQUOTE ((BLOCK INNER (IL:\\\,@ (IF (NOT (> END START)) (IL:BQUOTE (
(SETQ ARGS (APPLY FN XP (IL:\\\, (ARGS)))))) (COMPILE-FORMAT START END)))))))))))))))) (GO L))))))))))
)))))
(DEF-FORMAT-HANDLER #\< (START END) (IF (COLONP (1- END)) (HANDLE-LOGICAL-BLOCK START END) (
HANDLE-STANDARD-< START END)))
(DEFUN HANDLE-STANDARD-< (START END) (LET ((N (NUM-ARGS-IN-DIRECTIVE START END))) (IL:BQUOTE (
USING-FORMAT XP (IL:\\\, (SUBSEQ *STRING* (1- START) END)) (IL:\\\,@ (COPY-TREE (MAKE-LIST N 
:INITIAL-ELEMENT (GET-ARG))))))))
(DEFUN NUM-ARGS-IN-DIRECTIVE (START END) (LET ((N 0) C I J) (INCF N (NUM-ARGS-IN-ARGS START T)) (
MULTIPLE-VALUE-SETQ (J I) (NEXT-DIRECTIVE1 START END)) (LOOP (MULTIPLE-VALUE-SETQ (C I J) (
NEXT-DIRECTIVE J END)) (WHEN (NULL C) (RETURN N)) (COND ((EQL C #\;) (IF (COLONP J) (ERR 22 
"~~:; not supported in ~~<...~~> by (formatter \"...\")." J))) ((FIND C "*[^<_IiWw{Tt") (ERR 23 
"~~<...~~> too complicated to be supported by (formatter \"...\")." J)) ((EQL C #\() (INCF N (
NUM-ARGS-IN-DIRECTIVE (1+ I) J))) ((FIND C "%&|~") (INCF N (NUM-ARGS-IN-ARGS (1+ I) T))) ((EQL C #\?) 
(WHEN (ATSIGNP J) (ERR 23 "~~<...~~> too complicated to be supported by (formatter \"...\")." J)) (
INCF N 2)) ((FIND C "AaSsDdBbOoXxRrCcFfEeGg$Pp") (INCF N (1+ (NUM-ARGS-IN-ARGS (1+ I) T))))))))
(DEF-FORMAT-HANDLER #\_ (START END) (DECLARE (IGNORE END)) (MULTIPLE-VALUE-BIND (COLON ATSIGN) (
PARSE-PARAMS START IL:NIL) (IL:BQUOTE (PPRINT-NEWLINE+ (IL:\\\, (COND ((AND COLON ATSIGN) :MANDATORY) 
(COLON :FILL) (ATSIGN :MISER) (T :LINEAR))) XP))))
(DEF-FORMAT-HANDLER #\I (START END) (DECLARE (IGNORE END)) (MULTIPLE-VALUE-BIND (COLON ATSIGN PARAMS) 
(PARSE-PARAMS START (QUOTE (0)) :NOATSIGN T) (DECLARE (IGNORE ATSIGN)) (IL:BQUOTE (PPRINT-INDENT+ (
IL:\\\, (IF COLON :CURRENT :BLOCK)) (IL:\\\, (CAR PARAMS)) XP))))
(DEF-FORMAT-HANDLER #\W (START END) (DECLARE (IGNORE END)) (MULTIPLE-VALUE-BIND (COLON ATSIGN) (
PARSE-PARAMS START IL:NIL) (COND ((NOT (OR COLON ATSIGN)) (IL:BQUOTE (WRITE+ (IL:\\\, (GET-ARG)) XP)))
 (T (IL:BQUOTE (LET ((IL:\\\,@ (IF COLON (QUOTE ((*PRINT-PRETTY* T))))) (IL:\\\,@ (IF ATSIGN (QUOTE ((
*PRINT-LEVEL* IL:NIL) (*PRINT-LENGTH* IL:NIL)))))) (WRITE+ (IL:\\\, (GET-ARG)) XP)))))))
(DEFUN HANDLE-LOGICAL-BLOCK (START END) (MULTIPLE-VALUE-BIND (COLON ATSIGN) (PARSE-PARAMS START IL:NIL
) (SETQ START (1+ (PARAMS-END START))) (LET* ((CHUNKS (CHUNK-UP START END)) (ON-EACH-LINE? (AND (CDDR 
CHUNKS) (ATSIGNP (1- (CADR CHUNKS))))) (PREFIX (COND ((CDDR CHUNKS) (POP CHUNKS) (SUBSEQ *STRING* 
START (DIRECTIVE-START (CAR CHUNKS)))) (COLON "("))) (SUFFIX (COND ((CDDR CHUNKS) (SUBSEQ *STRING* (
CADR CHUNKS) (DIRECTIVE-START (CADDR CHUNKS)))) (COLON ")")))) (WHEN (CDDDR CHUNKS) (ERR 24 
"Too many subclauses in ~~<...~~:>" (1- START))) (WHEN (AND PREFIX (OR (FIND #\~ PREFIX) (FIND 
#\Newline PREFIX))) (ERR 25 "Prefix in ~~<...~~:> must be a literal string without newline" START)) (
WHEN (AND SUFFIX (OR (FIND #\~ SUFFIX) (FIND #\Newline SUFFIX))) (ERR 26 
"Suffix in ~~<...~~:> must be a literal string without newline" (CADR CHUNKS))) (CAR (BIND-ARGS T (IF 
ATSIGN (IL:BQUOTE (PROG1 (IL:\\\, (ARGS)) (SETQ (IL:\\\, (ARGS)) IL:NIL))) (GET-ARG)) (BIND-INITIAL (
IL:BQUOTE ((PPRINT-LOGICAL-BLOCK+ (XP (IL:\\\, (ARGS)) (IL:\\\, PREFIX) (IL:\\\, SUFFIX) (IL:\\\, 
ON-EACH-LINE?) (IL:\\\, (NOT (AND *AT-TOP* ATSIGN))) (IL:\\\, ATSIGN)) (IL:\\\,@ (FILL-TRANSFORM (
ATSIGNP (1- END)) (LET ((*GET-ARG-CAREFULLY* T) (*AT-TOP* (AND *AT-TOP* ATSIGN)) (*INNER-END* (QUOTE 
LOGICAL-BLOCK)) (*OUTER-END* (QUOTE LOGICAL-BLOCK))) (COMPILE-FORMAT (CAR CHUNKS) (DIRECTIVE-START (
CADR CHUNKS)))))))))))))))
(DEFUN CHECK-BLOCK-ABBREVIATION (XP ARGS CIRCLE-CHECK?) (COND ((NOT (LISTP ARGS)) (WRITE+ ARGS XP) T) 
((AND *PRINT-LEVEL* (> *CURRENT-LEVEL* *PRINT-LEVEL*)) (WRITE-CHAR++ #\# XP) (SETQ 
*ABBREVIATION-HAPPENED* T) T) ((AND *CIRCULARITY-HASH-TABLE* CIRCLE-CHECK? (EQ (CIRCULARITY-PROCESS XP
 ARGS IL:NIL) :SUBSEQUENT)) T) (T IL:NIL)))
(DEFUN FILL-TRANSFORM (DOIT? BODY) (IF (NOT DOIT?) BODY (MAPCAN (FUNCTION (LAMBDA (FORM) (COND ((EQ (
CAR FORM) (QUOTE WRITE-STRING++)) (FILL-TRANSFORM-LITERAL (CADR FORM))) ((EQ (CAR FORM) (QUOTE 
WRITE-CHAR++)) (FILL-TRANSFORM-CHAR (CADR FORM))) (T (LIST FORM))))) BODY)))
(DEFUN FILL-TRANSFORM-CHAR (CHAR) (IF (OR (CHAR= CHAR #\Space) (CHAR= CHAR #\Tab)) (LIST (IL:BQUOTE (
WRITE-CHAR++ (IL:\\\, CHAR) XP)) (QUOTE (PPRINT-NEWLINE+ :FILL XP))) (IL:BQUOTE ((WRITE-CHAR++ (IL:\\\,
 CHAR) XP)))))
(DEFUN FILL-TRANSFORM-LITERAL (STRING) (FLET ((WHITE-SPACE (C) (OR (CHAR= C #\Space) (CHAR= C #\Tab)))
) (DO ((INDEX 0 END) (RESULT) (END IL:NIL IL:NIL)) (IL:NIL) (LET ((WHITE (POSITION-IF (FUNCTION 
WHITE-SPACE) STRING :START INDEX))) (WHEN WHITE (SETQ END (POSITION-IF-NOT (FUNCTION WHITE-SPACE) 
STRING :START (1+ WHITE)))) (WHEN (NULL END) (SETQ END (LENGTH STRING))) (PUSH (IL:BQUOTE (
WRITE-STRING++ (IL:\\\, (SUBSEQ STRING INDEX END)) XP (IL:\\\, 0) (IL:\\\, (- END INDEX)))) RESULT) (
IF WHITE (PUSH (QUOTE (PPRINT-NEWLINE+ :FILL XP)) RESULT)) (IF (NULL WHITE) (RETURN (NREVERSE RESULT))
)))))
(DEFUN PRETTY-ARRAY (XP ARRAY) (COND ((VECTORP ARRAY) (PRETTY-VECTOR XP ARRAY)) ((ZEROP (ARRAY-RANK 
ARRAY)) (WRITE-STRING++ "#0A " XP 0 4) (WRITE+ (AREF ARRAY) XP)) (T (PRETTY-NON-VECTOR XP ARRAY))))
(DEFUN PRETTY-VECTOR (XP V) (PPRINT-LOGICAL-BLOCK (XP IL:NIL :PREFIX "#(" :SUFFIX ")") (LET ((END (
LENGTH V)) (I 0)) (WHEN (PLUSP END) (LOOP (PPRINT-POP) (WRITE+ (AREF V I) XP) (IF (= (INCF I) END) (
RETURN IL:NIL)) (WRITE-CHAR++ #\Space XP) (PPRINT-NEWLINE+ :FILL XP))))))
(DEFUN PRETTY-NON-VECTOR (XP ARRAY) (LET* ((BOTTOM (1- (ARRAY-RANK ARRAY))) (INDICES (MAKE-LIST (1+ 
BOTTOM) :INITIAL-ELEMENT 0)) (DIMS (ARRAY-DIMENSIONS ARRAY))) (FUNCALL (FORMATTER "#~DA") XP (1+ 
BOTTOM)) (LABELS ((PRETTY-SLICE (SLICE) (PPRINT-LOGICAL-BLOCK (XP IL:NIL :PREFIX "(" :SUFFIX ")") (LET
 ((END (NTH SLICE DIMS)) (SPOT (NTHCDR SLICE INDICES)) (I 0)) (WHEN (PLUSP END) (LOOP (PPRINT-POP) (
SETF (CAR SPOT) I) (IF (= SLICE BOTTOM) (WRITE+ (APPLY (FUNCTION AREF) ARRAY INDICES) XP) (
PRETTY-SLICE (1+ SLICE))) (IF (= (INCF I) END) (RETURN IL:NIL)) (WRITE-CHAR++ #\Space XP) (
PPRINT-NEWLINE+ (IF (= SLICE BOTTOM) :FILL :LINEAR) XP))))))) (PRETTY-SLICE 0))))
(DEFUN PPRINT-LINEAR (S LIST &OPTIONAL (COLON? T) ATSIGN?) (DECLARE (IGNORE ATSIGN?)) (
PPRINT-LOGICAL-BLOCK (S LIST :PREFIX (IF COLON? "(" "") :SUFFIX (IF COLON? ")" "")) (
PPRINT-EXIT-IF-LIST-EXHAUSTED) (LOOP (WRITE+ (PPRINT-POP) S) (PPRINT-EXIT-IF-LIST-EXHAUSTED) (
WRITE-CHAR++ #\Space S) (PPRINT-NEWLINE+ :LINEAR S))))
(DEFUN PPRINT-FILL (S LIST &OPTIONAL (COLON? T) ATSIGN?) (DECLARE (IGNORE ATSIGN?)) (
PPRINT-LOGICAL-BLOCK (S LIST :PREFIX (IF COLON? "(" "") :SUFFIX (IF COLON? ")" "")) (
PPRINT-EXIT-IF-LIST-EXHAUSTED) (LOOP (WRITE+ (PPRINT-POP) S) (PPRINT-EXIT-IF-LIST-EXHAUSTED) (
WRITE-CHAR++ #\Space S) (PPRINT-NEWLINE+ :FILL S))))
(DEFUN PPRINT-TABULAR (S LIST &OPTIONAL (COLON? T) ATSIGN? (TABSIZE IL:NIL)) (DECLARE (IGNORE ATSIGN?)
) (WHEN (NULL TABSIZE) (SETQ TABSIZE 16)) (PPRINT-LOGICAL-BLOCK (S LIST :PREFIX (IF COLON? "(" "") 
:SUFFIX (IF COLON? ")" "")) (PPRINT-EXIT-IF-LIST-EXHAUSTED) (LOOP (WRITE+ (PPRINT-POP) S) (
PPRINT-EXIT-IF-LIST-EXHAUSTED) (WRITE-CHAR++ #\Space S) (PPRINT-TAB+ :SECTION-RELATIVE 0 TABSIZE S) (
PPRINT-NEWLINE+ :FILL S))))
(DEFUN FN-CALL (XP LIST) (FUNCALL (FORMATTER "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") XP LIST))
(DEFUN ALTERNATIVE-FN-CALL (XP LIST) (IF (> (LENGTH (SYMBOL-NAME (CAR LIST))) 12) (FUNCALL (FORMATTER 
"~:<~1I~@{~W~^ ~_~}~:>") XP LIST) (FUNCALL (FORMATTER "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") XP LIST)))
(DEFUN BIND-LIST (XP LIST &REST ARGS) (DECLARE (IGNORE ARGS)) (IF (DO ((I 50 (1- I)) (LS LIST (CDR LS)
)) ((NULL LS) T) (WHEN (OR (NOT (CONSP LS)) (NOT (SYMBOLP (CAR LS))) (MINUSP I)) (RETURN IL:NIL))) (
PPRINT-FILL XP LIST) (FUNCALL (FORMATTER "~:<~@{~:/xp:pprint-fill/~^ ~_~}~:>") XP LIST)))
(DEFUN BLOCK-LIKE (XP LIST &REST ARGS) (DECLARE (IGNORE ARGS)) (FUNCALL (FORMATTER 
"~:<~1I~^~W~^ ~@_~W~^~@{ ~_~W~^~}~:>") XP LIST))
(DEFUN DEFUN-LIKE (XP LIST &REST ARGS) (DECLARE (IGNORE ARGS)) (FUNCALL (FORMATTER 
"~:<~1I~W~^ ~@_~W~^ ~@_~:/xp:pprint-fill/~^~@{ ~_~W~^~}~:>") XP LIST))
(DEFUN PRINT-FANCY-FN-CALL (XP LIST TEMPLATE) (LET ((I 0) (IN-FIRST-SECTION T)) (PPRINT-LOGICAL-BLOCK+
 (XP LIST "(" ")" IL:NIL T IL:NIL) (WRITE+ (PPRINT-POP) XP) (PPRINT-INDENT+ :CURRENT 1 XP) (LOOP (
PPRINT-EXIT-IF-LIST-EXHAUSTED) (WRITE-CHAR++ #\Space XP) (WHEN (EQ I (CAR TEMPLATE)) (PPRINT-INDENT+ 
:BLOCK (CADR TEMPLATE) XP) (SETQ TEMPLATE (CDDR TEMPLATE)) (SETQ IN-FIRST-SECTION IL:NIL)) (
PPRINT-NEWLINE (COND ((AND (ZEROP I) IN-FIRST-SECTION) :MISER) (IN-FIRST-SECTION :FILL) (T :LINEAR)) 
XP) (WRITE+ (PPRINT-POP) XP) (INCF I)))))
(DEFUN MAYBELAB (XP ITEM &REST ARGS) (DECLARE (IGNORE ARGS) (SPECIAL NEED-NEWLINE INDENTATION)) (WHEN 
NEED-NEWLINE (PPRINT-NEWLINE+ :MANDATORY XP)) (COND ((AND ITEM (SYMBOLP ITEM)) (WRITE+ ITEM XP) (SETQ 
NEED-NEWLINE IL:NIL)) (T (PPRINT-TAB+ :SECTION INDENTATION 0 XP) (WRITE+ ITEM XP) (SETQ NEED-NEWLINE T
))))
(DEFUN FUNCTION-CALL-P (X) (AND (CONSP X) (SYMBOLP (CAR X)) (FBOUNDP (CAR X))))
(DEFUN LET-PRINT (XP OBJ) (FUNCALL (FORMATTER "~:<~1I~W~^ ~@_~/xp:bind-list/~^~@{ ~_~W~^~}~:>") XP OBJ
))
(DEFUN COND-PRINT (XP OBJ) (FUNCALL (FORMATTER "~:<~W~^ ~:I~@_~@{~:/xp:pprint-linear/~^ ~_~}~:>") XP 
OBJ))
(DEFUN DMM-PRINT (XP LIST) (PRINT-FANCY-FN-CALL XP LIST (QUOTE (3 1))))
(DEFUN DEFSETF-PRINT (XP LIST) (PRINT-FANCY-FN-CALL XP LIST (QUOTE (3 1))))
(DEFUN DO-PRINT (XP OBJ) (FUNCALL (FORMATTER 
"~:<~W~^ ~:I~@_~/xp:bind-list/~^ ~_~:/xp:pprint-linear/ ~1I~^~@{ ~_~W~^~}~:>") XP OBJ))
(DEFUN FLET-PRINT (XP OBJ) (FUNCALL (FORMATTER 
"~:<~1I~W~^ ~@_~:<~@{~/xp:block-like/~^ ~_~}~:>~^~@{ ~_~W~^~}~:>") XP OBJ))
(DEFUN FUNCTION-PRINT (XP LIST) (IF (AND (CONSP (CDR LIST)) (NULL (CDDR LIST))) (FUNCALL (FORMATTER 
"#'~W") XP (CADR LIST)) (FN-CALL XP LIST)))
(DEFUN MVB-PRINT (XP LIST) (PRINT-FANCY-FN-CALL XP LIST (QUOTE (1 3 2 1))))
(DEFUN PROG-PRINT (XP LIST) (LET ((NEED-NEWLINE T) (INDENTATION (1+ (LENGTH (SYMBOL-NAME (CAR LIST))))
)) (DECLARE (SPECIAL NEED-NEWLINE INDENTATION)) (FUNCALL (FORMATTER 
"~:<~W~^ ~:/xp:pprint-fill/~^ ~@{~/xp:maybelab/~^ ~}~:>") XP LIST)))
(DEFUN SETQ-PRINT (XP OBJ) (FUNCALL (FORMATTER "~:<~W~^ ~:I~@_~@{~W~^ ~:_~W~^ ~_~}~:>") XP OBJ))
(DEFUN QUOTE-PRINT (XP LIST) (IF (AND (CONSP (CDR LIST)) (NULL (CDDR LIST))) (FUNCALL (FORMATTER "'~W"
) XP (CADR LIST)) (PPRINT-FILL XP LIST)))
(DEFUN TAGBODY-PRINT (XP LIST) (LET ((NEED-NEWLINE (AND (CONSP (CDR LIST)) (SYMBOLP (CADR LIST)) (CADR
 LIST))) (INDENTATION (1+ (LENGTH (SYMBOL-NAME (CAR LIST)))))) (DECLARE (SPECIAL NEED-NEWLINE 
INDENTATION)) (FUNCALL (FORMATTER "~:<~W~^ ~@{~/xp:maybelab/~^ ~}~:>") XP LIST)))
(DEFUN UP-PRINT (XP LIST) (PRINT-FANCY-FN-CALL XP LIST (QUOTE (0 3 1 1))))
(DEFUN TOKEN-TYPE (TOKEN &AUX STRING) (COND ((NOT (SYMBOLP TOKEN)) :EXPR) ((STRING= (SETQ STRING (
STRING TOKEN)) "FINALLY") :FINALLY) ((MEMBER STRING (QUOTE ("IF" "WHEN" "UNLESS")) :TEST (FUNCTION 
STRING=)) :COND-HEAD) ((MEMBER STRING (QUOTE ("DO" "DOING" "INITIALLY")) :TEST (FUNCTION STRING=)) 
:LINEAR-HEAD) ((MEMBER STRING (QUOTE ("FOR" "AS" "WITH" "AND" "END" "ELSE" "REPEAT" "NAMED" "WHILE" 
"UNTIL" "ALWAYS" "NEVER" "THEREIS" "RETURN" "COLLECT" "COLLECTING" "APPEND" "APPENDING" "NCONC" 
"NCONCING" "COUNT" "COUNTING" "SUM" "SUMMING" "MAXIMIZE" "MAXIMIZING" "MINIMIZE" "MINIMIZING")) :TEST 
(FUNCTION STRING=)) :BLOCK-HEAD) (T :EXPR)))
(DEFUN PRETTY-LOOP (XP LOOP) (IF (NOT (AND (CONSP (CDR LOOP)) (SYMBOLP (CADR LOOP)))) (IL:* IL:\; 
"old-style loop") (FUNCTION-PRINT XP LOOP) (PPRINT-LOGICAL-BLOCK (XP LOOP :PREFIX "(" :SUFFIX ")") (
LET (TOKEN TYPE) (LABELS ((NEXT-TOKEN IL:NIL (PPRINT-EXIT-IF-LIST-EXHAUSTED) (SETQ TOKEN (PPRINT-POP))
 (SETQ TYPE (TOKEN-TYPE TOKEN))) (PRINT-CLAUSE (XP) (CASE TYPE (:LINEAR-HEAD (PRINT-EXPRS XP IL:NIL 
:MANDATORY)) (:COND-HEAD (PRINT-COND XP)) (:FINALLY (PRINT-EXPRS XP T :MANDATORY)) (OTHERWISE (
PRINT-EXPRS XP IL:NIL :FILL)))) (PRINT-EXPRS (XP SKIP-FIRST-NON-EXPR NEWLINE-TYPE) (LET ((FIRST TOKEN)
) (NEXT-TOKEN) (IL:* IL:\; "so always happens no matter what") (PPRINT-LOGICAL-BLOCK (XP IL:NIL) (
WRITE FIRST :STREAM XP) (WHEN (AND SKIP-FIRST-NON-EXPR (NOT (EQ TYPE :EXPR))) (WRITE-CHAR #\Space XP) 
(WRITE TOKEN :STREAM XP) (NEXT-TOKEN)) (WHEN (EQ TYPE :EXPR) (WRITE-CHAR #\Space XP) (PPRINT-INDENT 
:CURRENT 0 XP) (LOOP (WRITE TOKEN :STREAM XP) (NEXT-TOKEN) (WHEN (NOT (EQ TYPE :EXPR)) (RETURN IL:NIL)
) (WRITE-CHAR #\Space XP) (PPRINT-NEWLINE NEWLINE-TYPE XP)))))) (PRINT-COND (XP) (LET ((FIRST TOKEN)) 
(NEXT-TOKEN) (IL:* IL:\; "so always happens no matter what") (PPRINT-LOGICAL-BLOCK (XP IL:NIL) (WRITE 
FIRST :STREAM XP) (WHEN (EQ TYPE :EXPR) (WRITE-CHAR #\Space XP) (WRITE TOKEN :STREAM XP) (NEXT-TOKEN))
 (WRITE-CHAR #\Space XP) (PPRINT-INDENT :BLOCK 2 XP) (PPRINT-NEWLINE :LINEAR XP) (PRINT-CLAUSE XP) (
PRINT-AND-LIST XP) (WHEN (STRING= (STRING TOKEN) "ELSE") (PRINT-ELSE-OR-END XP) (WRITE-CHAR #\Space XP
) (PPRINT-NEWLINE :LINEAR XP) (PRINT-CLAUSE XP) (PRINT-AND-LIST XP)) (WHEN (STRING= (STRING TOKEN) 
"END") (PRINT-ELSE-OR-END XP))))) (PRINT-AND-LIST (XP) (LOOP (WHEN (NOT (STRING= (STRING TOKEN) "AND")
) (RETURN IL:NIL)) (WRITE-CHAR #\Space XP) (PPRINT-NEWLINE :MANDATORY XP) (WRITE TOKEN :STREAM XP) (
NEXT-TOKEN) (WRITE-CHAR #\Space XP) (PRINT-CLAUSE XP))) (PRINT-ELSE-OR-END (XP) (WRITE-CHAR #\Space XP
) (PPRINT-INDENT :BLOCK 0 XP) (PPRINT-NEWLINE :LINEAR XP) (WRITE TOKEN :STREAM XP) (NEXT-TOKEN) (
PPRINT-INDENT :BLOCK 2 XP))) (PPRINT-EXIT-IF-LIST-EXHAUSTED) (WRITE (PPRINT-POP) :STREAM XP) (
NEXT-TOKEN) (WRITE-CHAR #\Space XP) (PPRINT-INDENT :CURRENT 0 XP) (LOOP (PRINT-CLAUSE XP) (WRITE-CHAR 
#\Space XP) (PPRINT-NEWLINE :LINEAR XP)))))))
(DEFUN BQ-PRINT (XP LIST) (IF (AND (CONSP (CDR LIST)) (NULL (CDDR LIST))) (FUNCALL (FORMATTER "`~W") 
XP (CADR LIST)) (PPRINT-FILL XP LIST)))
(DEFUN BQ-COMMA-PRINT (XP LIST) (IF (AND (CONSP (CDR LIST)) (NULL (CDDR LIST))) (FUNCALL (FORMATTER 
",~W") XP (CADR LIST)) (PPRINT-FILL XP LIST)))
(DEFUN BQ-COMMA@-PRINT (XP LIST) (IF (AND (CONSP (CDR LIST)) (NULL (CDDR LIST))) (FUNCALL (FORMATTER 
",@~W") XP (CADR LIST)) (PPRINT-FILL XP LIST)))
(DEFUN IL-COMMENT (XP THING) (IL:* IL:\; "Edited  8-Jul-92 13:44 by jrb:") (POP THING) (IL:* IL:\; 
"Flush the IL:*") (FLET ((HOSE-COMMENT-STRING (S) (DO ((START (POSITION #\Space S :TEST (QUOTE IL:NEQ)
)) (END)) ((NULL START)) (IF (SETQ END (POSITION #\Space S :START START)) (PROGN (CL:WRITE-STRING S XP
 :START START :END (1+ END)) (WHEN (SETQ START (POSITION #\Space S :START END :TEST (QUOTE IL:NEQ))) (
PPRINT-NEWLINE :FILL XP))) (PROGN (CL:WRITE-STRING S XP :START START) (SETQ START IL:NIL)))))) (IL:* 
IL:|;;| 
"This method of handling Interlisp comments sucks, BUT there is no way under XP to temporarily ignore an existing per-line-prefix, which is what you would have to do to get ;;; and ;;;; comments to go to the left margin.  Phooey!"
) (LET (PER-LINE-PREFIX) (CASE (CAR THING) ((IL:\; IL:|;;| IL:|;;;| IL:|;;;;|) (SETQ PER-LINE-PREFIX (
CONCATENATE (QUOTE STRING) (SYMBOL-NAME (CAR THING) " ")))) (IL:* IL:|;;| 
"Last two cases have their own logical blocks, since they either have weird :PREFIX/:SUFFIXes or aren't strings"
) (IL:\| (IL:* IL:\; "a #|ignore everything|#") (CL:FRESH-LINE XP) (PPRINT-LOGICAL-BLOCK (XP IL:NIL 
:PREFIX "#|" :SUFFIX "|#") (HOSE-COMMENT-STRING (CADR THING)))) (T (IL:* IL:|;;| 
"an OLD-style comment; punt and use ;;, but just use PPRINT-FILL since the body of the comment is not a string"
) (PPRINT-LOGICAL-BLOCK (XP IL:NIL :PER-LINE-PREFIX ";; ") (PPRINT-FILL XP THING IL:NIL)))) (WHEN 
PER-LINE-PREFIX (PPRINT-LOGICAL-BLOCK (XP IL:NIL :PER-LINE-PREFIX PER-LINE-PREFIX) (
HOSE-COMMENT-STRING (CADR THING)))) (PPRINT-NEWLINE :MANDATORY XP) (IL:* IL:\; 
"ALWAYS end comments with a newline"))))
(SETQ *IPD* (MAKE-PPRINT-DISPATCH))
(XCL:DEF-DEFINE-TYPE INITIAL-DISPATCH "XP initial pretty-print dispatch entries")
(XCL:DEFDEFINER SET-PPD-IPD INITIAL-DISPATCH (TYPE-SPECIFIER FUNCTION &OPTIONAL (PRIORITY (QUOTE (0)))
) (IL:BQUOTE (SET-PPRINT-DISPATCH+ (QUOTE (IL:\\\, TYPE-SPECIFIER)) (IL:\\\, FUNCTION) (IL:\\\, 
PRIORITY) *IPD*)))
(SET-PPD-IPD (SATISFIES FUNCTION-CALL-P) (FUNCTION FN-CALL) (QUOTE (-5)))
(SET-PPD-IPD CONS (FUNCTION PPRINT-FILL) (QUOTE (-10)))
(SET-PPD-IPD (CONS (MEMBER DEFSTRUCT)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER BLOCK)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER CASE)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER CATCH)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER CCASE)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER COMPILER-LET)) (FUNCTION LET-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER COND)) (FUNCTION COND-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER CTYPECASE)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DEFCONSTANT)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DEFINE-SETF-METHOD)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DEFMACRO)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DEFINE-MODIFY-MACRO)) (FUNCTION DMM-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DEFPARAMETER)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DEFSETF)) (FUNCTION DEFSETF-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DEFINE-SETF-METHOD)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER CL:DEFSTRUCT)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DEFTYPE)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DEFUN)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DEFVAR)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DO)) (FUNCTION DO-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DO*)) (FUNCTION DO-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DO-ALL-SYMBOLS)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DO-EXTERNAL-SYMBOLS)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DO-SYMBOLS)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DOLIST)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER DOTIMES)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER ECASE)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER ETYPECASE)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER EVAL-WHEN)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER FLET)) (FUNCTION FLET-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER FUNCTION)) (FUNCTION FUNCTION-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER LABELS)) (FUNCTION FLET-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER LAMBDA)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER LET)) (FUNCTION LET-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER LET*)) (FUNCTION LET-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER LOCALLY)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER LOOP)) (FUNCTION PRETTY-LOOP) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER MACROLET)) (FUNCTION FLET-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER MULTIPLE-VALUE-BIND)) (FUNCTION MVB-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER MULTIPLE-VALUE-SETQ)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER PROG)) (FUNCTION PROG-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER PROG*)) (FUNCTION PROG-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER PROGV)) (FUNCTION DEFUN-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER PSETF)) (FUNCTION SETQ-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER PSETQ)) (FUNCTION SETQ-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER QUOTE)) (FUNCTION QUOTE-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER RETURN-FROM)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER SETF)) (FUNCTION SETQ-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER SETQ)) (FUNCTION SETQ-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER TAGBODY)) (FUNCTION TAGBODY-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER THROW)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER TYPECASE)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER UNLESS)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER UNWIND-PROTECT)) (FUNCTION UP-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER WHEN)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER WITH-INPUT-FROM-STRING)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER WITH-OPEN-FILE)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER WITH-OPEN-STREAM)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER WITH-OUTPUT-TO-STRING)) (FUNCTION BLOCK-LIKE) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER IL:*)) (FUNCTION IL-COMMENT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER IL:BQUOTE)) (FUNCTION BQ-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER IL:\\\,)) (FUNCTION BQ-COMMA-PRINT) (QUOTE (0)))
(SET-PPD-IPD (CONS (MEMBER IL:\\\,@)) (FUNCTION BQ-COMMA@-PRINT) (QUOTE (0)))
(DEFUN PPRINT-DISPATCH-PRINT (XP TABLE) (DECLARE (IGNORE LEVEL)) (LET ((STUFF (COPY-LIST (OTHERS TABLE
)))) (MAPHASH (FUNCTION (LAMBDA (KEY VAL) (DECLARE (IGNORE KEY)) (PUSH VAL STUFF))) (CONSES-WITH-CARS 
TABLE)) (MAPHASH (FUNCTION (LAMBDA (KEY VAL) (DECLARE (IGNORE KEY)) (PUSH VAL STUFF))) (STRUCTURES 
TABLE)) (SETQ STUFF (SORT STUFF (FUNCTION PRIORITY->) :KEY (FUNCTION (LAMBDA (X) (CAR (FULL-SPEC X))))
)) (PPRINT-LOGICAL-BLOCK (XP STUFF :PREFIX "#<" :SUFFIX ">") (FORMAT XP (FORMATTER 
"pprint dispatch table containing ~A entries: ") (LENGTH STUFF)) (LOOP (PPRINT-EXIT-IF-LIST-EXHAUSTED)
 (LET ((ENTRY (PPRINT-POP))) (FORMAT XP (FORMATTER "~{~_P=~4D ~W~} F=~W ") (FULL-SPEC ENTRY) (FN ENTRY
)))))))
(SETF (GET (QUOTE PPRINT-DISPATCH) (QUOTE CL::STRUCTURE-PRINTER)) (FUNCTION PPRINT-DISPATCH-PRINT))
(SET-PPD-IPD PPRINT-DISPATCH (FUNCTION PPRINT-DISPATCH-PRINT) (QUOTE (0)))
(WHEN (EQ *PRINT-PPRINT-DISPATCH* T) (SETQ *PRINT-PPRINT-DISPATCH* (COPY-PPRINT-DISPATCH IL:NIL)))
(IL:PUTPROPS IL:XP IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "XP" (:USE "LISP") (
:SHADOW "CLEAR-OUTPUT" "FORCE-OUTPUT" "FINISH-OUTPUT" "DEFSTRUCT" "FRESH-LINE" "TERPRI" "WRITE-CHAR" 
"WRITE-STRING" "WRITE-LINE" "PRIN1-TO-STRING" "PRINC-TO-STRING" "WRITE-TO-STRING" "FORMAT" "PPRINT" 
"PRINC" "PRIN1" "PRINT" "WRITE") (:IMPORT-FROM "COMMON-LISP" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" 
"*PRINT-RIGHT-MARGIN*" "*PRINT-PPRINT-DISPATCH*" "PPRINT-TAB" "PPRINT-INDENT" "PPRINT-NEWLINE" 
"PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" "PPRINT-LOGICAL-BLOCK" "PPRINT-TABULAR" "PPRINT-LINEAR" 
"PPRINT-FILL" "SET-PPRINT-DISPATCH" "PPRINT-DISPATCH" "COPY-PPRINT-DISPATCH" "FORMATTER") (:EXPORT 
"*PRINT-SHARED*" "*LAST-ABBREVIATED-PRINTING*" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" 
"*DEFAULT-RIGHT-MARGIN*" "*PRINT-RIGHT-MARGIN*" "*PRINT-PPRINT-DISPATCH*" "PPRINT-TAB" "PPRINT-INDENT"
 "PPRINT-NEWLINE" "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" "PPRINT-LOGICAL-BLOCK" "PPRINT-TABULAR"
 "PPRINT-LINEAR" "PPRINT-FILL" "SET-PPRINT-DISPATCH" "PPRINT-DISPATCH" "COPY-PPRINT-DISPATCH" 
"FORMATTER")) :BASE 10))
(IL:PUTPROPS IL:XP IL:FILETYPE :COMPILE-FILE)
(IL:PUTPROPS IL:XP IL:COPYRIGHT ("Venue Corporation" 1990 1991 1992 1993))
IL:NIL