github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-02-08 09:21:17 +00:00
Code Issues Releases Wiki Activity
Files
6f48b261d3c59cab2be2f4e69a89b206ce45a5a3
PDP-10.its/src/libdoc/#print.rcw3
Eric Swenson 02d9eb9851 Built a bunch of missing FASL files from LIBLSP. 
Resolves #1287.
2018-10-03 07:33:27 -07:00

4252 lines
218 KiB
Common Lisp
Raw Blame History

This file contains invisible Unicode characters
This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
;-*-LISP-*-
(comment a fast pretty printer)
;-----------------------------------------------------------;
; -- THIS FILE IS OBSOLETE -- USE GPRINT -- ;
;-----------------------------------------------------------;
;this file was written by Richard C. Waters Feb. 1978.
;all comments and bugs should go to DICK@AI
; --- AN ADVERTISMENT FOR THIS PRINTER ---
;the goal of this printing package is to produce a general purpose printer which
;combines the best features of PRINT and GRINDEF while correcting some of their
;deficiencies.
;GOOD FEATURES OF PRINT RETAINED
; PRINLEVEL and PRINLENGTH abbreviation,
; printing of HUNKs in a recognizable way,
; reasonable speed.
;GOOD FEATURES OF GRINDEF RETAINED
; nice formatting of output,
; grind-functions for specifying your own formatting.
;BAD FEATURES CORRECTED
; GRINDEF is too slow, this is improved by simplifying the look ahead and virtually
; eliminating consing.
; the old printers blow up on circular lists, this is fixed by putting in a module that
; checks for circularity. (this can be disabled if you don't like the overhead it
; creates).
; there isn't any way to stop the old printers, you can turn off seeing the output, but
; you still have to wait until it's done computing unless you type a ^g and wipe
; out the whole environment. this is fixed by providing an interrupt function
; which causes the printer to immediatly abort and return normally.
; structure, and printing nothing if the object passed to #print is a naked ||.
;NEW FEATURES ADDED
; a new abbreviation mode is introduced. special variables PRINSTARTLINE and PRINENDLINE
; can be used to specify how many lines to print out. for example you could
; specify that only the first 4 lines should be printed out. an interrupt
; function is provided so that you can see the rest of the output if you want to.
; this works if the output is at top level, or from inside a program.
; a new format for grinding is introduced. it prints out a block of data in a tabular
; format where the width of the columns is automatically generated. it is useful
; for increasing the readability of densely printed stuff.
; a new method of specifying a grinding format is introduced. It allows you to construct
; a template which controls the format of printing. it can be used to produce a
; wide variety of formats, and is considerably simpler than writing a grind
; function.
; The #printer doesn't print anything to the left of the column position that
; it starts printing in. This is very usefull when the #printer is
; being called as a subroutine by some other function which is pretty
; printing something (eg when it is being used like SPRINT).
; #prin1 prints out nothing for "||" if "||" is passed to it as a single atom,
; and prints "||" for it inside a structure. This is handy since you
; can have a function return '|| and not have to see anything printed out.
;IN DEPTH DOCUMENTATION OF HOW TO USE THE #PRINTER
;
;this documentation is arranged into a set of sections which describe more and more
;advanced levels of interaction with the printer. what you should read depends on
;what you want to do. if you just want to load it in and use it without
;creating any of your own formats for printing things, then just read sections
;0 and 1. In order to make your own templates, and/or functions for
;formatting, you need to read about #GRIND-TEMPLATEs and #GRIND-FNs. (you will
;have to read a good deal of the rest in order to realy understand them) In
;order to set up your own printing system you will have to read everything
;including the implementation notes.
;
;The code for the #print programs appears after this initial set of comments.
;It is written in terms of a bunch of macros which are in the file dick;util >.
;Since there is some difficulty in understanding these macros, if you are
;not familiar with them, the end of this file contains a completely macro
;expanded version of these same programs.
;
;(the functions and special variables in this file start with # so that they will
; not collide with any names in other program packages. (for added safety a lot
; of things which are considered internal to the package begin with #1))
;
;SECTION 0 (JUST LOAD IT IN AND USE IT AS THE TOP LEVEL TTY PRINTER)
;
;HOW TO LOAD #PRINT
; a. execute (fasload #print fasl dsk liblsp)
;
;HOW TO START UP #PRINT
; a. execute (#1set-up-printer) this sets '#prin1 as the value of prin1
; (thus making it the default printer) and sets up ^S and ^C (see below).
; (you can just do (setq prin1 '#prin1) if you don't want the control
; characters)
; b. DO NOT change the fsubr properties of prin1 or princ since #print uses
; them.
;
;HOW TO GET RID OF THE #PRINTER
; a. execute (#1rem-printer) this undoes all of the actions of
; #1SET-UP-PRINTER and gets rid of the functions in the #print package.
; The primary use is to save space before creating a dumped version,
; however, #print really doesn't take up much space.
;THE BASIC STRUCTURE OF THE #PRINTER
;
;the #printer is implemented as three sets of programs which communicate with
; each other through two narrow bottle necks.
; 1. top level print functions like #PRINT, PRINL, and GRINDEF (see section 1)
; these form an easy interface for getting something printed. there are
; also a set of special varibles which control the format of printout
; (see section 1)
; 1-2. all of these functions eventually call #1PRINTER. this function then
; communicates the critical information about what to print and how with
; (2.) below. this is done partly through argument passing and partly
; through a set of special variables.
; 2. this set of programs formats an object for output. in doing this it
; creates an intermediate structure which tells how to format each part
; of the object if that part will not fit on one line. these functions
; use a set of special variables to communicate with each other. in
; addition they use atom properties and a few special variables to get
; information directly from the user. Furthermore, these routines are
; specifically designed so that they can be modified by the user.
; (each of these mechanisms is described in detail below)
; 2-3. the net result of the formatting functions in (2.) above is a sequence
; of calls on the function #1ENTER-OBJ. this function forms the complete
; interface with (3.) below. #1ENTER-OBJ constructs an ellaborate intermediate
; structure which is represented in several special variables. this part
; and (3.) below are extreamly convoluted and are not intended to be
; modified by the user.
; 3. the function #1PRINTOUT actually decides what will go where and prints
; the object out. it uses a number of special variables to communicate
; with itself and #1ENTER-OBJ.
;
;the general high speed of the #PRINTer is due to two things:
; 1. the #PRINTer does very little look ahead, in particular, it calls
; FLAT(SIZE/C) only once on each atom in the structure to be printed, and
; never calls it with a non atomic argument.
; 2. the #PRINTer does almost no consing. rather it does its own storage
; management including keeping a queue in an array. this greatly reduces
; garbage collections. the only consing is the fixnum consing which is
; neccessary because some special variables have fixnum values.
; fortunately most of these values are relatively static and/or small.
;SECTION 1 THE BASIC USER FUNCTIONS AND ABBREVIATION CONTROL VARIABLES
;
;the functions #PRINT, #PRIN1, and #PRINC are analogous to the functions
; PRINT, PRIN1, and PRINC. they are LSUBRs and take two arguments. the first
; must be an object to print out. the second can be either: a file, a list
; of files, NIL, or missing (in the last two cases the default files
; specified by ^R, ^W, and OUTFILES are used as output destinations)
;
;there a several special variables which can be used to control the amount of
; abbreviation which is performed by the printer. in each case if the
; variable has the value NIL then there is no abbreviation corresponding to
; that variable. (The #printer requires that all of these variables be BOUND
; and makes sure that this is the case when it is loaded in. (this is done
; by the function #1SET-UP-GLOBALS which gives all of the controling
; variables which are unbound a default value of NIL (ie no abbreviation)))
; 1. PRINLEVEL: just like PRINT, #PRINT prints # for lists which are at a
; depth greater than PRINLEVEL. It extends the definition of elision used in
; PRINT in that it forces prinlength to 3 at the deapest level printed. This
; is so that you don't see a long string of #'s at that level.
; 2. PRINLENGTH: just like PRINT, #PRINT prints ... for the ends of lists
; which are longer than PRINLENGTH. It extends the definition of elision
; used in PRINT in that if only one element of a list is going to be omitted
; and that element is an atom, then it is not omitted.
; 3. PRINENDLINE: #PRINT counts the lines it prints out (starting with the
; first line as line 0) and stops printing after printing the
; PRINENDLINEth line. if truncation occures, --- is printed at the end
; of the last line (if there is room). the printer then immediatly stops
; executing and returns no matter how large the output object is.
; 4. PRINSTARTLINE: if PRINSTARTLINE is greater than zero, then #PRINT skips
; over the initial lines of output and does not start to print out untill
; the PRINSTARTLINEth line is reached. (note that if PRINSTARTLINE is
; greater then PRINENDLINE nothing is going to print out) (also note that
; like PRINLEVEL and PRINLENGTH, PRINENDLINE and PRINSTARTLINE must be
; non-negative.)
; 5. #CHECKRECURSION: if this variable is non null then, #PRINT checks for
; circular lists and prints ^# for circular references where # is the number of
; cars and cdrs separating the two references to the item. for example,
; t1=(1 2 ^2) implies that (eq (cdr t1) (caddr t1)).
;
;there is a special variable PRINMODE which specifies what format #PRINT
; will use to print things out. (this is discussed more fully below)
; PRINMODE can take on two basic values:
; 1. 'CRUSH gives you crushed together output similar to PRINT. atoms are
; not broken over line boundries.
; 2. 'GRIND (or NIL) gives you nicely formated output like GRINDEF. (there
; are a number of ways that you can control what this looks like
; (see below))
;
;Hunks are printed out in a format different from the way PRINT prints them. Each
; hunk is printed as "{" cxr1 cxr2 cxr3 ... cxr0 "}". Thus
; (hunk 1 2 (hunk 3 4 5) 6) prints as
; {1 2 {3 4 5} 6}.
;there are two functions which are intended to be put on interrupt characters.
; (calling #1SET-UP-PRINTER sets these up)
; 1. #PRINTABORT (^S) causes the printer to stop and return normally.
; 2. #CONTINUE (^C) will cause the printer to resume printing from where it left
; off printing the last object which was truncated by ^S or prinendline. Note
; that this may not be the last thing which was #printed. Also, it only works on a
; line by line basis so there may be some duplication if the object printout was
; truncated by ^S (#PRINTABORT). #CONTINUE uses CURSORPOS and is only intended
; to work on output devises which support CURSORPOS.
; A special endpage function (#1ENDPAGEFN) is
; provided because the system one does not correctly do MORE
; processing with the printout produced by #CONTINUE (I think that this has
; something to do with #CONTINUE being on an interrupt character). this new
; endpage function is installed by #1SET-UP-PRINTER.
;
;there are three functions (PRINL, PRINL1, and PRINLC) which are analogous to
; #PRINT, #PRIN1, and #PRINC except that they allow you to specify the
; control parameters PRINLEVEL, PRINLENGTH, PRINENDLINE,
; PRINSTARTLINE, and PRINMODE as arguments rather than by setting the
; global variables. useing PRINL as an example, the argument order is:
; (PRINL object level length endline startline mode file) as an added
; conveniance, any of these arguments (except the object) can be omitted
; and will take on a default value (of NIL which means no abbreviation)
; as long as there is no ambiguity. the only abiguity that can arize is
; with the four numeric parameters (level, length, endline, and
; startline). with these, you must specify an initial subset of them.
; the most common way to call PRINL is (PRINL object file) this prints
; out the entire object on file (much like SPRINT). other valid calls on
; PRINL are: (PRINL foo 3 4 'grind tyo) ;this sets level=3 and length=4
; (PRINL bar nil nil 4) ;this sets endline=4
;
;there is a redefinition of the function GRINDEF which calls #PRINT. it is an
; FSUBR and takes arguments just like the old grindef. IE the first argument
; (which may be omitted) is a list of properties to grind. this list of
; properties is used in conjunction with the list of properties in the variable
; GRINDPROPERTIES in order to decide what properties of the specified atoms to
; print out. the remaining arguments to GRINDEF are atoms.
;
;there are three functions #EXPLODE, #EXPLODEC, and #EXPLODEL which correspond
; to #PRIN1, #PRINC, and #PRINL. They don't actually print anything out,
; rather they return a list of the characters which would be printed out
; if the whole structure fit on one line. (note that this includes all
; abbreviation which would have been used. #EXPLODEL allows you to
; directly specify the abbreviation parameters.) For example,
; (#explode '(1 2 3)) => '(/( /1 / /2 / /3 /))
; but if PRINLENGTH = 2 then it returns:
; (#explode '(1 2 3)) => '(/( /1 / /2 / /. /. /. /))
; as long as PRINMODE is 'GRIND then all macro inversion etc. happens ie:
; (#explodel '(1 (quote 2)) 'grind) => '(/( /1 / /'/2/))
;IMPLEMENTATION NOTE ON SECTION 1 (THE FUNCTION #1PRINTER)
;
;the function #1PRINTER takes 3 arguments:
; (#1PRINTER code object parameters) The first is a code which specifies what
; type of printing to do. The second argument is the object to print, and the
; last indicates the files to print out on. The code is a number which is
; decoded bit by bit as follows:
; bit0 - if 1 then atoms are PRINCed instead of PRIN1ed.
; bit1 - if 1 then a TERPRI is done before starting to print, and a
; space is printed at the end (like PRINT)
; bit2 - if 1 then the third argument is taken to be, not just
; files, but also an explicit specification of the abbreviation
; parameters (prinlevel prinlength prinendline prinstartline
; prinmode) (the way these are pattern matched out of the string
; provided is discussed as part of the discusion of PRINL above).
; bit3 - if 1 then #1PRINTER does an explode instead of actually
; printing anything.
; The function #1PRINTER is used to implement the functions #PRINT etc.
;
;#1PRINTER performs several main tasks:
; 1. if it is reentered while another call on it has not yet completed, it
; rebinds all of the special varibles used by the #PRINT system so that
; the old invocation will be protected while the current call is completed
; (the special variable #1NOWPRINTING is used as a flag to tell whether or
; not the #printer is being reentered). this enables the #PRINTer to work
; perfectly when it is reentered, the only change in its actions is that
; it creates a certain amount of garbage when it reinitializes itself
; whereas in general it does almost no CONSing.
; 2. #1PRINTER takes care of outputing crlf before output of #PRINT and
; #PRINL and a space after (as controled by #1PRINT-LIKE).
; 3. it takes care of printing || differently if it is the object to be
; printed than if it is in the object to be printed.
; 4. before calling the formatting routines to print out the object, #1PRINTER
; sets up a CATCH which enables #1PRINTABORT (^S) to stop the printer.
; this is also used to implement stopping when prinendline is reached.
; 5. the special variable #1TRUNCATED is used to keep track of whether the
; output is truncated or not, and if so on what line. if non-null, it holds a
; list of all the information needed to resume printing in the right place.
; This is used by #1CONTINUE to decide where to start printing out.
; #1PRINTER sets up the value of #1TRUNCATED whenever #1PRINTABORT or
; PRINENDLINE triggers the truncation of output. #1TRUNCATED is a list
; of the following components:
; 1. the CURSORPOS (line . column) where printing stopped.
; 2. the indentation where printing started in the first place.
; 3. the primary output file (#1MAINFILE).
; 4. the CODE which should be used when calling #1printer in order to
; continue printing out the truncated object.
; 5. the MAKNUM of the object being printed. (the maknum is used so
; that this will not prevent the object from getting garbage
; collected)
; 6. the abbreviation parameter list which should be passed to
; #1printer in order to continue printing the object. it has the form:
; a. the current prinlevel
; b. the current prinlength
; c. a prinendline of NIL
; d. a prinstartline of the line where truncation occured.
; e. the current prinmode
; f. the files being printed on.
; 6. most importantly, #1PRINTER translates the format control information into the
; form that the formatting routines expect. (see the discussion below of
; the special variables used to communicate with the format funcions.) In addition, the
; function #1FORMAT-INIT is called to set up the special variables which
; are used during the formatting and printout processes.
;
;if you wish to dispence with #1PRINTER and write a program which directly
; calls the format functions, you must make sure that the above variables
; are at least bound, and you must call #1FORMAT-INIT before calling the
; format functions. also note that you will be loosing the features which
; are implemented directly by #1PRINTER unless you make provision for them.
;THE SPECIAL VARIABLES USED BY THE TOP LEVEL FUNCTIONS:
;
;Variables which are set by the user to control certain fucntions:
; #checkrecursion (t/nil) this controls checking for circularity.
; prinlevel (a non-negative number or nil) this controls # abbreviation if
; structures get too deep.
; prinlength (a non-negative number or nil) this controls ... abbreviation if
; structures are too long.
; prinmode (a keyword, or a template (see below)) this controls the format of
; output it is discussed fully in the section on templates below.
; prinendline (a non-negative number or nil) this controls the number of lines
; which are printed out.
; prinstartline (a non-negative number or nil) this controls which line is the
; first line actually printed out.
; ^r (t/nil) if T this implies that the variable OUTFILES will be used to
; decide what files to output onto. (this is the same convention as with PRINT).
; ^w (t/nil) if NIL this implies that output will be done to the file in the
; variable TYO. (This is completely orthoganal to ^R and is the same convention
; as with PRINT)
; outfiles (a list of files) this is a list of files to perform output to.
; tyo (a file) this is the file which is the default "tty" file.
; grindproperties (a list of properties) this controls what the default properties
; displayed by GRINDEF will be.
;
;Variables which are used for communication between top level functions:
; #1print-like (t/nil) if T then a space is put after, and a crlf before what
; is being printed. this is used by #1PRINTER.
; #1nowprinting (t/nil) if T this says that there is an unfinished call on
; #1PRINTER on the stack. In that case all the volitile special variables
; are rebound before starting up another call on #1PRINTER in order to
; protect the state of the old call. This is used by #1PRINTER.
; grindef (the last argument to GRINDEF) this is used to implement the fact
; that (GRINDEF) does what ever the last call on GRINDEF did. THis is used
; by GRINDEF.
; #1mainfile (a file) this is a file which has been selected as the primary
; output file. It is used to make formating decisions based on such things
; as line length. In addition #CONTINUE tries to make its output look
; perfect on #1MAINFILE while it ends up only OK on the other files, if any.
; it is either the first file specified (if literal files were specified to
; a printing function) or the first file in OUTFILES if ^R and ^W are both
; T, or otherwise it is the value of TYO. (if it should turn out that
; #1MAINFILE failed to end up as a valid file things wouldn't work out
; right even if you were only #EXPLODEing.)
; #1truncated (nil or a description of an object which was truncated) this is
; created by #1PRINTER in order to communicate with #CONTINUE. It holds
; all of the information which #CONTINUE needs to finish printing
; something. (It is discussed in detail above.)
;Variables which form the interface between the top level functions and the
; format functions:
; #1princ-atoms (t / nil) is t if atoms should be PRINCed instead of PRIN1ed.
; #1files (list of files) holds a list of the files to print onto. (it can be NIL which
; implies that ^R ^W and OUTFILES will be used to decide where output will go.
; #1checkrecursion (t/nil) holds the value of #CHECKRECURSION.
; #1prinlevel (positive number) holds the value of #PRINLEVEL except that it is always a
; number. instead of NIL, a very large number is used to inhibit abbreviation.
; #1prinlength (positive number) holds the value of #PRINLENGTH except that it is always a
; number. instead of NIL, a very large number is used to inhibit abbreviation.
; #1prinlendline (positive number) holds the value of #PRINENDLINE except that it is always a
; number. instead of NIL, a very large number is used to inhibit abbreviation.
; #1prinstartline (positive number) holds the value of #PRINSTARTLINE except
; that it is always a number. instead of NIL, a 0 is used to inhibit
; abbreviation.
; #1prinmode (positive number) holds the value of PRINMODE (see the discussion of templates
; below) except that if PRINMODE is a keyword (such as GRIND) then the
; keyword is translated into a template.
; #1exploding (t/nil) is t if the #printer should produce a list of characters
; rather than print anything out.
; #1explode-result (a list of characters) (initialized to nil) is used to pass
; the results of #exploding back up to #1PRINTER. it collects the
; nreverse of the result.
; 1st arg of #1format-dispatch is the template to use when formatting the
; object. this is taken from the variable #1PRINMODE.
; 2nd arg of #1format-dispatch is the object to be formated.
;SECTION 2 CALLS ON THE FUNCTION #1ENTER-OBJ
;
;In order to print something, a sequence of calls on the function #1ENTER-OBJ
; is created. In order to understand the capabilities of the #printer,
; it is important to look at what a sequence of calls on #1ENTER-OBJ is like.
;
;the functions #1ENTER-OBJ takes three arguments: (#1enter-obj obj pcode lcode)
; In addition it looks at two global variables: #1fcode and #1bcode (the MACRO
; #1ENTER-FORMAT (#1enter-format fcode bcode) is available for setting these two
; global variables. The MACRO #1ENTER-FORMAT&OBJ (#1enter-format&obj fcode
; bcode obj pcode lcode) sets these two variables and then calls (#1enter-obj
; obj pcode lcode).) The separation between the two sets of inputs is
; motivated by the fact that the function invocation which sets the
; format, is often different from the one which decides what object to
; print. Put another way, the format depends on the context the object
; is in, while how the object itself is printed depends on the object
; itself. This will be discussed more fully below.
;
;Logically, #1ENTER-OBJ takes five arguments:
; 1. obj -- an object to be printed. The formatting functions (see below)
; convert a thing to be #printed into a sequence of objects to be
; printed. this sequence includes list delimeters on an equal footing
; with atoms in the thing to be printed. for example when #printing
; "(list (cons var1 var2) var3 var4)" the following sequence of 10 objects is
; created "/( list /( cons var1 var2 /) var3 var4 /)". The standard
; #printer only calls #1enter-obj with atomic objects, but a list or
; hunk could be used; however, it will be treated just like an indivisable atom.
; 2. pcode -- the printing code is one of {princ, prin1, nil} and specifies
; whether to use PRIN1 and FLATSIZE, or PRINC and FLATC when working
; with the object. a pcode of nil indicates that the object has been
; omitted, and there is no object to be printed corresponding to this
; call on #1enter-obj.
; 3. lcode -- the list code is one of {start, end, nil}. It is used to
; encode the nested structure of the thing being printed. It is
; motivated by the nesting in lists, but need not correspond to any
; actual delimiters, nor be limited to lists. For example the cxrs of
; a hunk, which are printed out inside "{}"s, are a nested structure like
; any other from the point of view of the calls on #1enter-obj. The
; lcode of END means that this object is the last object in a
; substructure. The lcode NIL indicates that this is neither the first
; nor last object in a substructure.
; the lcode START indicates the start of a nested structure. In
; addition, it indicates that the obj parameter is not an object to be
; printed, but rather the amount of indentation to use when printing out
; the substructure which starts here. This requires that an extra call
; on #1ENTER-OBJ be made at the start of each substructure. This extra
; call on #1ENTER-OBJ (the one with lcode=start) is a "header cell" for
; a nested structure. One the one hand, it is not part of the nested
; structure, but rather just introduces it; it contains general
; information which applies to the whole substructure (like the
; indentation, and the fcode and bcode (see below) for the substructure
; as a whole. On the other hand, the header cell is often operated on
; as a unit, refering to the entire substructure.
; the example above "(list (cons var1 var2) var3 var4)" can now be seen
; to generate 12 calls on #1ENTER-OBJ:
(declare '| obj pcode lcode
(#1enter-obj 6 nil 'start)
(#1enter-obj '/( 'princ nil)
(#1enter-obj 'list 'prin1 nil)
(#1enter-obj 6 nil 'start)
(#1enter-obj '/( 'princ nil)
(#1enter-obj 'cons 'prin1 nil)
(#1enter-obj 'var1 'prin1 nil)
(#1enter-obj 'var2 'prin1 nil)
(#1enter-obj '/) 'princ 'end)
(#1enter-obj 'var3 'prin1 nil)
(#1enter-obj 'var4 'prin1 nil)
(#1enter-obj '/) 'princ 'end) |)
; the indentation is "6" in the two substructures because LIST and CONS
; are being printed in functional notation which calls for an
; indentation of (+ (the length of the open delimeter (here 1))
; (the length of the function name (here 4))
; (the amount of spacing over ie 1)) = 6.
; 4. fcode -- a keyword which must be one of {never, normal, tblock, block, always}
; It describes the circumstances under which a crlf will be printed
; before the object to be printed. (NOTE that if this fcode is
; associated with a call on #1ENTER-OBJ which starts a substructure, then
; the "object being printed" refered to below, is the entire
; substructure. also note that the "prior object printed" may also
; refer to an entire substructure.)
; ALWAYS -- a crlf is always put before this item.
; NEVER -- a crlf will never be put before this object, unless the
; object is too long to fit on the end of the current line. If the
; object is the start of a substructure then a crlf is never
; inserted no matter how long it is. (in general non-atomic
; structures are not given 'NEVER fcodes.)
; In order to make it more likely, that NEVER really means never, the
; printer works with a logical line length which is 5 characters
; shorter than the actual line length. However, when it comes to
; processing a NEVER, the #printer uses the actual line length.
; The 5 character cushion is available only for printing NEVER objects
; NORMAL -- a crlf is put before this object if and only if the substructure
; containing this object was to long to fit on the end of the line
; it started on. Note that this is not a function of the object
; itself, but rather a function of the containing substructure.
; This is used to generate standard list output format: either,
; every element of the list is on the same line, or each one is on
; a separate line.
; BLOCK -- a crlf is put before this object if and only if either,
; this object is a substructure which has somewhere in it an ALWAYS
; code, or the prior object at the same level did not fit on one line, or
; this object is too long to fit on the end of this line.
; This is used to generate "block" output where several list
; elements are put on each line.
; TBLOCK -- a crlf is put before this object in exactly the same
; situations as with the BLOCK code. the difference is that when
; the objects are printed out, tabing is done in order to line them
; up in columns. (this variant of BLOCK can be much more readable.)
; NOTE that the #printer NEVER inserts two crlfs in a row.
;
; The routine which does output goes inside a substructure, and breaks
; it up in only two cases. The first case is when the substructure is
; simply too long to fit on one line. (the outputer first does as much
; as possible given the fcodes of the containing stuctures to start the
; substructure as far to the left as possible. The second case occures
; if the substructure contains an ALWAYS fcode somewhere inside itself.
; If the outputer looks inside a substructure, then that substructure
; may be broken up over several lines in order to make it fit.
; Otherwise, the substructure will appear as a unit on one line.
; 5. bcode -- this specifies the number of blanks to print out AFTER
; printing this item (usually 1 or 0). Note, that the bcode associated
; with an lcode of START is actually printed out after the object
; associated with the corresponding END lcode. IE it appears after the
; entire logical object. The bcode (if any)
; associated directly with the END lcode is IGNORED. there are no
; blanks printed out in conjunction with processing the START lcode.
; Note further, that blanks are never printed as the last characters
; on a line. therefore the bcodes associated with those objects that
; happen to end up on the end of a line are effectively ignored.
;
;now we can look at a complete example of the sequence of calls generated by
; the example, assuming that it is being printed in standard grind format.
;
(declare '|"(list (cons var1 var2) var3 var4)" leads too:
fcode bcode obj pcode lcode
1 (#1enter-format&obj 'never 0 6 nil 'start)
2 (#1enter-format&obj 'never 0 '/( 'princ nil)
3 (#1enter-format&obj 'never 1 'list 'prin1 nil)
4 (#1enter-format&obj 'never 1 6 nil 'start)
5 (#1enter-format&obj 'never 0 '/( 'princ nil)
6 (#1enter-format&obj 'never 1 'cons 'prin1 nil)
7 (#1enter-format&obj 'never 1 'var1 'prin1 nil)
8 (#1enter-format&obj 'normal 0 'var2 'prin1 nil)
9 (#1enter-format&obj 'never _ '/) 'princ 'end)
10 (#1enter-format&obj 'normal 1 'var3 'prin1 nil)
11 (#1enter-format&obj 'normal 0 'var4 'prin1 nil)
12 (#1enter-format&obj 'never _ '/) 'princ 'end)
if the line length were 21 then this would print out as:
(list (cons var1
var2)
var3
var4) |)
;
;In order to get a deaper understanding of how this works, consider the
; following trace of how the output part of the #printer would interpret
; this in order to produce output. Suppose that the line length on the
; primary output device was 21. The output section processes the calls
; on #1ENTER-OBJ one at a time (it actually does this as a coroutine with
; the functions which produce the calls on #1ENTER-OBJ, but this is only an
; efficiency issue (it reduces the amount of temporory storage needed)).
; Note that one question which the outputer often asks is how long
; something is. For effeciency, this is computed incrementally, but
; this aspect will be ignored here.
; Suppose the printer started out in column 0. When presented with
; the 1st call on #1ENTER-OBJ it asks whether or not the corresponding
; object (in this case the whole expression) is too long to fit on one
; line. Here the object is 33 chars long and there is only space for
; 21. The output point is already at the start of a line, so the system
; looks inside the substructure in order to see how to break it up.
; The system then looks at the 2nd call. the fcode is NEVER, so no
; crlf is done. a /( is printed out. the bcode is 0 so no blanks are
; printed.
; The 3rd call also has a NEVER fcode, so no crlf is printed. a
; "list" is printed (prin1ed since that is specified). then 1 blank is
; printed as specified by the bcode.
; The 4th call is a substructure header cell (as was the 1st). It
; has an fcode of NEVER so no crlf is printed, However, the current
; output point is column 6 (the first column is 0), and the length of
; this substructure is 17. as a result, it is not going to fit on this
; line. as a result the system goes down inside it to see how it can
; get broken up. (if it had been shorter (say 10) then the system
; would have printed all of it out (calls 4-9) without looking at any of
; those calls in detail.
; Since the system is looking inside, it looks at calls 5,6, & 7.
; they all have NEVER fcodes so they just print things out (even though
; we are getting closer and closer to the end of the line). They print
; out |(cons var1 |.
; Call 8 has an fcode of NORMAL. this specifies that a crlf should
; be inserted if the containing substructure is being broken up (which
; it is). (note that effectively the output system only looks at the
; fcode if the superior is being broken up.) As a result a crlf is
; done. Note that if the fcode had been BLOCK or TBLOCK then the
; system would have done a crlf because there isn't room to print the
; object in call 8 in the space left on the line. Further if the fcode
; had been NEVER the system would still have done a crlf as an emergency
; measure since you just can't print "var2" in the space left.
; After doing a crlf for call 8 the system spaces over to the
; current indentation (which is 12 6+6 for the two substructures which
; have been broken up.) The system then prints |var2|.
; It then looks at call 9. This has a NEVER fcode and so the
; system prints out /). In addition, call 9 has an END lcode. As a result, the
; system prints out a blank because a bcode of 1 was specified in the call (call
; 4) which was the header for this substructure. The current indentation is
; popped back to 6 corresponding to the one substructure which the system is
; down in.
; Call 10 has a NORMAL fcode so the system does crlf, and indents
; to the 6th column. It then prints |var3 |
; call 11 also has a NORMAL fcode so the system again does crlf,
; indents to 6 and then prints |var3|. (Note here that if the fcode
; had been BLOCK then the system would not have done a crlf since the
; object actually would fit on the same line as call 10.)
; Finally call 12 causes the outputer to print /) and pop up out of
; the structure being printed.
;SECTION 3 TEMPLATES
;
;As stated above, everything in the printer eventually boils down to a
; sequence of calls on #1ENTER-OBJ. In order to make it easier to get
; the correct sequence of calls generated, there is a structure called a
; template. A template in conjunction with a few conventions specifies
; what the sequence of calls will be. The conventions specify what the
; open and close delimeters are, and what their fcodes are. In addition
; they specify what all of the bcodes are, and the order in which the
; internal items of each substructure will appear. The template
; specifies the indentation, and what the fcodes of the internal items
; of each substructure will be.
; 1. the fcode and bcode associated with the header cell for a
; substructure is inhereted from the fcode and bcode expected of it
; based on its position in the structure which contains it. (note
; the highest level call has an fcode of NEVER and a bcode of 0 in
; all situations.) The template specifies the indentation which
; goes in the header cell.
; 2. the second and last calls for a substructure are the open and
; close delimiters respectively. the second call (the open delimeter) is /(
; for a list and /{ for a hunk. Its fcode is NEVER (so that it will always
; appear on the line the thing printed out starts on) and its bcode is nil.
; The last call (the close delimiter) is /) for a list and /} for a hunk. Its
; fcode is never (so that it will always be on the same line as the last item
; in the list or hunk being printed) and as noted above its bcode is ignored
; by the system.
; 3. The substructure structure of the calls on #1ENTER-OBJ follow
; exactly the tree structure of the thing being printed.
; 4. for a list, the elements of the list make up the 3rd through
; next to last calls. They each have a pcode of PRIN1 (or PRINC
; if #1PRINC-ATOMS is non-null). They each have a bcode of 1
; except the last element of the list (the next to last call)
; which has a bcode of 0. The template specifies the fcodes of
; these calls.
; 5. Hunks are exactly analogous with the cxrs appearing in the
; order 1,2,3, ... ,0.
;a template has a nested structure corresponding exactly to the nested
; structure of the thing being printed, and therefore also corresponding to the
; nested structure of calls on #1ENTER-OBJ created. They are motivated by the
; observation that the sequence of fcodes desired, for the internal items of a
; substructure usually takes the form of some initial sequence followed by an
; unbounded repeating pattern . Templates simulate this by being recursive
; through their cdrs. Similarly, they are often circular through there cars.
;
;the following is a "grammer" for templates:
; template := explicit-temp v NIL
; explicit-temp := ( indent-count item-temp*n )
; indent-count := number v NIL
; item-temp := ( {NEVER v ALWAYS v NORMAL v BLOCK v TBLOCK} . template )
;
; A template of NIL indicates that the template mechanism is not being
; used, and the format functions (see below) use other means for
; deciding what sequene of calls on #1enter-obj to create.
; An indent-count of NIL indicates that the indent code to use is
; (+ (Flatsize (first of list)) 1 (flatsize open-delimeter)).; This is
; used in creating standard functional indentation.
;
; the template specifies the indent-count, and for each internal
; item in each substructure, the fcode to use for it, and a template to
; use when formatting its internal strucutre. for example, the following
; template (shown as #print would print it) could be used to make
; everything print out in lisp function format. (it could have been used
; to generate the example in the previous section.)
; '(nil (never . ^3) (never . ^4) (normal . ^5) . ^1)
; Note that it is heavily recursive. Each of the subtemplates is
; itself, and it ends in an endless sequence of NORMAL fcodes.
;
; The example above corresponds to this template in that each substructure has
; an open delimeter with a NEVER fcode, and then two NEVER fcodes followed by
; NORMAL fcodes, and finally a close delimeter with a NEVER fcode. The car
; recursiveness of the template causes every substructure to be treated just the
; same way as the top structure is.
;
;There is a function #MAKE-TEMPLATE (with an associated sub-function
; #MAKE-TEMPLATE1) which can be used to easily generate these circular
; structures. This function allows you to specify a circular structure
; by giving the function a list as an argument which contains ellements of the
; form "(^ . n)". the input is copied, and each of these special
; elements is replaced by its nth parent in the new structure. the copy
; is then returned. (note that this does not damage the input, and
; works even if the input is itself circular.) the template above could
; have been created by:
; (#make-template
; '(nil (never . (^ . 3)) (never . (^ . 4)) (normal . (^ . 5)) . (^ . 1)))
;Having discussed templates, we can now give a complete explanation of the
; special variable PRINMODE. This variable can either be one of the
; atoms {GRIND, CRUSH, BLOCK, TBLOCK, MISER}, or a template. The
; variable #1PRINMODE (which actually controls the #printing process)
; must always be a template. If PRINMODE is an atom, then the function
; #1printer translates this atom into a template as follows:
; GRIND => nil
; CRUSH => (-900 (never . ^3) . ^1)
; BLOCK => (1 (never . ^3) (block . ^4) . ^1)
; TBLOCK => (1 (never . ^3) (tblock . ^4) . ^1)
; MISER => (1 (never . ^3) (normal . ^4) . ^1)
; Looking at these we can see what these modes will do, and more about
; how the formatting works in the #printer. The CRUSH template causes
; things to get printed out without formatting except that atoms are not
; broken up accross lines. all of its fcodes are NEVER, so that a crlf
; is only inserted when the very next atom to be printed won't fit on the
; rest of the current line. further the large negative indentation,
; guarrentees that the total indentation will allways be negative. this
; cuases printing to always start out as far left as the intial
; indentation point (note that the #printer will never go left of the
; initial indentation point).
; The BLOCK, TBLOCK, and MISER templates are very similar.
; They all specify indentations of 1. Assuming that the only open
; delimiters #printed are /( and /{ then this means that substructure
; elements are indented just enough to line up after the open delimiter.
; They all have NEVER as the first fcode, which ensures that the first
; item will be on the same line as the open delimiter. They then give
; all of the rest of the elements the same fcode. For BLOCK, these fcode
; is BLOCK and the resulting output looks like GRINDEF's block format,
; crlfs are inserted before any substructure which will not fit on one
; line, however, if several will fit on one line then they are put
; there. TBLOCK is just the same except that the elements printed out
; are lined up in columns like in a table. MISER prints things out like
; GRINDEF's miser format. The elements of a substructure are either all
; printed on one line, or each is printed on a separate line.
;
(declare '| the following gives comparative examples of these four printing
modes. It is based on the assumption that the line length is 30.
(list f foo bar (list (list a CRUSH mode
b) zap) a b c)
(list MISER mode
f
foo
bar
(list (list a b) zap)
a
b
c)
(list f foo bar BLOCK mode
(list (list a b) zap)
a b c)
(list f foo bar TBLOCK mode (this example assumes that the
(list (list a b) zap) #printer only saw the first four
a b c) elements of the list when it decided
what the tab spacing should be. This
is typical of the system's limited
look ahead.)
BLOCK and TBLOCK modes are most usefull for working with data structures. the following is
a data structure #printed out in BLOCK format. this saves a great deal of space over MISER
format and is a great deal more readable than CRUSH format would be.
((EXAMP1 CONSTANT1) (CONSTANT1 _*I1) (_*I1 _+I1) (_+I1 _GT1)
((_GT1 CE1) CONSTANT2) ((_GT1 CE0) (JOIN1 CE6)) (JOIN1 EXAMP1) (CONSTANT2 (JOIN2 CE5))
(JOIN2 _AREF1) (_AREF1 _A=1) (_A=1 CONSTANT3) (CONSTANT3 _+I2) (_+I2 _-I1) (_-I1 _GT2)
((_GT2 CE0) (JOIN2 CE2)) ((_GT2 CE1) (JOIN1 CE2)))
However, it still isn't all that readable. TBLOCK format (as shown below) is a great
deal more readable. It makes it a lot easier to identify the individual items at the top
level.
((EXAMP1 CONSTANT1) (CONSTANT1 _*I1) (_*I1 _+I1)
(_+I1 _GT1) ((_GT1 CE1) CONSTANT2) ((_GT1 CE0) (JOIN1 CE6))
(JOIN1 EXAMP1) (CONSTANT2 (JOIN2 CE5)) (JOIN2 _AREF1)
(_AREF1 _A=1) (_A=1 CONSTANT3) (CONSTANT3 _+I2)
(_+I2 _-I1) (_-I1 _GT2) ((_GT2 CE0) (JOIN2 CE2))
((_GT2 CE1) (JOIN1 CE2))) |)
; The template for GRIND is NIL. This means that the #printer
; will look at the structure of the thing being printed in order to
; decide how to format it. (This is discussed fully in the next
; section.) However, this usually ends up with the system having
; selected a particular template to use. One of these is for printing
; out functional forms:
; (nil (never) (never) (normal) . ^1)
; Note that this is a great deal like an example given earlier except
; that it specifies NIL for the templates of the substructures. This
; is so that after formatting the given list in functional form, it
; will again end up with a template of NIL in order to trigger the
; system to figure out how to print the substructures. this is the
; general way in which grinding proceeds.
; There one level templates for doing MISER, BLOCK, and TBLOCK
; output. analogous to the one level functional form template above,
; they con be used to specify one level of formating, and then they give
; a template of NIL so that new templates will be chosen for the lower
; levels. (these are held in the special variables
; #11level-miser-template, #11level-block-template, and
; #11level-tblock-template.)
; Another interesting template is the one which is used for
; formatting CONDs:
; (nil (never) (never . (1 (never) (normal) . ^1))
; (always . (1 (never) (normal) . ^1))
; . ^1)
; There are two interesting features of this. First, there is an
; always code which is used to insure that if a COND has more than one
; clause, it will go on more than one line no matter how short it is.
; Second, this template is two level while the last one was one level.
; it specifies the format for the COND, and the top level format for
; the clauses before becoming NIL.
;
;There is a function #1SET-UP-TEMPLATES which sets up a bunch of templates
; which are used by the rest of the system. This function is executed
; when #print is read in. a number of special variables are used to
; hold the templates which are built up. These variables should not be
; modified by the user. (the variables are #1miser-template
; #1block-template #1crush-template #1fn-template #11level-block-template
; #1defun1-template #1defun2-template #11level-tblock-template #1apply-template
; #11level-miser-template #1tblock-template)
;SECTION 4 THE FORMATTING FUNCTIONS
;
;The formatting functions take in an object to print and a template, and produce a sequence of
; calls on the function #1enter-obj. They don't actually print
; anything, however, they decide exactly how a thing will look when it
; is printed. In particular they implement prinlevel and prinlength
; abbreviation, circular structure abbreviation, and fancy formatting for
; grinding.
;
;The function #1FORMAT-INIT sets up a bunch of internal variables used by the
; format functions, and by #1ENTER-OBJ. It MUST be executed before a
; thing is formated! It reinitializes the world. #1PRINTER calls it
; before calling the formatting functions, if you bypass #1PRINTER you
; must call #1FORMAT-INIT yourself.
;
;as discussed above the main interface into the formatting functions is formed
; by the variables: #1princ-atoms, #1files, #1checkrecursion, #1prinlevel,
; #1prinlength, #1prinstartline, #1prinendline, #1prinmode, and #1exploding.
; Actually, #1files, #1prinstartline, #1prinendline, and #1exploding are not
; used by the formaters, and are just passed on to the function #1PRINTOUT.
; Further, the variable #1prinmode is not currently looked at (it is redundent
; with the template argument to the formaters).
; These variables are discussed above. In addition to them, each format
; function takes two arguments: a thing to be formated, and a template which
; says how to format it. (only #1FORMAT-DISPATCH can take a NIL template).
;
;The function #1FORMAT-DISPATCH takes a template and an item and decides which
; specific format function to call and what specific template to pass to
; it. In order to decide what to do #1FORMAT-DISPATCH looks at several
; features:
; 1. The primary feature is the type of the thing to print. It checks
; whether it is a hunk, list, or atom and uses different formaters
; in the three cases.
; 2. Second if there is a NIL template then it figures out what
; template to use. The interesting case of this is with lists. If
; the template is NIL then #1FORMAT-DISPATCH looks at the property
; list of the car of the list looking for #GRIND-TEMPLATE, and
; #GRIND-FN properties (see below).
; In any event it eventually calls a formatting function with an object,
; and a non-nil template.
;there are a variety of ways to effect the actions of #1FORMAT-DISPATCH
; 1. the variables #1FORMAT-DISPATCH, #1FORMAT-LIST,
; #1FORMAT-HUNK, and #1FORMAT-ATOM, are hooks for attaching your
; own formatting functions. If you give any of them a value, then
; this value will be FUNCALLed whenever the corresponding system
; function would have been. (note that if you write a formatting
; function it must be compatable with all of the restrictions
; described below. #1FORMAT-DISPATCH is a special case.)
;when #1FORMAT-DISPATCH gets a template of NIL then it looks at several
; other things in order to figure out what template to really use.
; 2. if you give an atom a #GRIND-TEMPLATE property then that property
; will be used as a template to print out lists whos cars are the
; given atom. COND, SETQ, and LAMBDA are given #GRIND-TEMPLATE
; properties when #print is loaded in.
; 3. the variable #1FN-GRIND-PROPERTIES is a list of properties. If
; an atom has any of these properties, then lists which start
; with it will print out in functional form.
; 4. the variable #1DEFAULT-SYMBOL-CAR-GRIND-TEMPLATE holds a template
; which is used when neither 2 nor 3 above are applicable.
; This is initially set up so that functional form is
; the default in this case. (this is what the old GRINDEF did)
; If this variable is set to #11level-tblock-template after fasloading #print
; then tab blocking will be done instead by default. This takes a little
; getting used to, but saves a lot of space when printing out on the tty. I
; recommend it.
; 5. the variable #1DEFAULT-NON-SYMBOL-CAR-GRIND-TEMPLATE holds a template
; which is used for lists whose cars are not atomic. (except that
; literal applications of lambda expressions have a special
; template which is held in the variable #1apply-template.) This is initially
; set up so that miser format (all the sublists indented 1 space) is used in
; this case (this is what old GRINDEF did). If this variable is set to
; #11level-tblock-template after fasloading #print then tab blocking will be
; done instead by default. This takes a little getting used to, but saves a lot
; of space when printing out on the tty. I recommend it.
; 6. If you give an atom a #GRIND-FN property, then that property will
; be FUNCALLed as the format function to use when the atom is the
; first of a list. (again this only applies when the template
; argument to #1FORMAT-DISPATCH is nil). When writing a formatting
; function to use this way you must follow the conventions set
; forth below. QUOTE, DEFUN, PROG, and DO are given special
; formatting functions at load time.
;The functions #1FORMAT-LIST and #1FORMAT-HUNK do the formatting of lists and
; hunks respectively. They have certain tasks they (like any formatting
; function) must perform:
; 1. They take a template as an argument (they could ignore it if they
; wanted to) they car cdr down the template in
; order get the correct fcodes, and indent count.
; 2. they call #1FORMAT-DISPATCH in order to do the formatting of
; EVERY subelement of the structures they are formatting.
; 3. as part of this they observe the convention that the variable
; #1FORMAT-DISPATCH may contain a user redefinition of the dispatching function.
; 4. They handle prinlength abbreviation. (this can be omitted)
; This is done by seeing that they don't output more than
; #1PRINLENGTH things in a substructure. They print |...| to
; indicate that something is being left out.
; 5. they handle prinlevel abbreviation. this is done in conjunction
; with the special variable #1LEVEL. If #1LEVEL is 0 when the
; formater is entered, then this indicates that the prinlevel is
; being exceeded. In this case the formaters output |#|. (It doesn't have to do
; abbreviation, but it must take care of #1LEVEL or else no one
; will be able to do prinlevel abbreviation right.)
; 6. they maintain the value of #1LEVEL (by decrementing it when they
; are entered, and incrementing it when they are exited). #1LEVEL is a
; number which is the difference between #1PRINLEVEL and the depth of
; the current sub-ellement being formated. If a format function
; simply didn't touch #1LEVEL, then it would not act like a level
; of structure from the point of view of the other formatting functions.
; 7. They check for recursion by calling the function #1RCHECK on
; every cons cell they encounter. If #1RINDEX returns something
; which is not EQ to its argument, then this indicates that its
; argument was recursive. In this case the formater should
; output the thing returned and not recurse into the item.
; The recursion checking is done in conjunction with
; the variable #1RINDEX. (this can be omitted, but #1RINDEX must be
; maintained or else no one will be able to do recursion checking correctly)
; 8. They maintain the value of #1RINDEX. #1RINDEX is a number which
; is the number of parents on the path from the current cons cell
; to the root of the top level object being printed. It is used by
; #1RCHECK which maintains an array (#1PARENTS) which holds that
; set of parents. #1RINDEX is maintaned by the formaters by
; saving its value on entry, and restoring this value before exit. If
; a formater doesn't call #1RCHECK, then it doesn't have to do
; anything with #1RINDEX.
; 9. #1FORMAT-LIST has special code to deal with atomic cdrs.
; 10. any formatting function must assume that the fcode and bcode which
; correspond to the object which is passed to it HAVE ALREADY BEEN
; SPECIFIED by the functions that called it. thus it should not
; specify the fcode or bcode for the top level thing it puts out.
; this is related to the tacit assumption that each formater will
; either just put out one thing, or will group everything it puts
; out into one substructure. If it doesn't do that, then it must
; take special steps to be compatable with the fcode and bcode its
; caller specified.
; 11. In line with this, a formater must specify an fcode and bcode BEFORE
; calling #1FORMAT-DISPATCH to deal with some substructure it needs
; to have formated.
; 12. Any formater should be carful that it will not crash on circular
; input even when recursion is not being checked for. that is to
; say that it should never do anything which could cause it to go
; into a loop without making any calls on #1ENTER-OBJ. (such as
; doing a flatsize of a non-atomic object.)
;The user can influence the actions of the formatting functions.
; 1. the variables #1OPEN-DEL and #1CLOSE-DEL can be used to modify
; the delimiters to be used by the formaters. setting them
; non-null cuases them to be used as the delimiters by the next
; call on a format function which recognizes them. However, they
; ONLY effect ONE call on the format functions. They do not cause
; a perminant change. the feature is used by the macro
; #MAKE-INVERT-QUOTE-FN which generates special format functions
; which do read macro inversion. (see below)
;the function #1RCHECK is a utility which is called by the formatting
; functions in order to check for recursive structures. It takes one
; input, an item. it either returns that item, or if #1CHECRECURSION
; is non-null and if the item is a recursive reference, #1RCHECK
; returns an atom of the form #^ where # is the number of cars and
; cdrs in the path from the first instance of the item, to this
; recursive instance of the item.
; In order to do this, #1RCHECK maintains an array (#1PARENTS)
; which contains the cells which are the ancesters of the current cell
; being checked. if that cell turns out not to be recursive, then it
; is put in the end of this array. The variable #1RINDEX points to
; the first free slot in the array #1parents. #1RCHECK increments
; #1RINDEX whenever it puts a new item in #1PARENTS, but it never
; decrements it. It is up to the formatting functions which call
; #1RCHECK to decrement #1RINDEX.
; The combination of #1PARENTS and #1RINDEX act like a stack.
; This stack follows the stack like order in which the formatting
; functions move over a thing to be printed. each call to #1RCHECK
; pushes a new item onto this stack. The formatting functions must see
; to it that these items get popped off of the stack. In order to do
; this each one saves the value of #1RINDEX when it starts to work,
; and then restores that value of #1RINDEX before it returns. this
; reflects the fact that each formatting function works on a single
; subtree and thus the state of #1PARENTS should be the same before
; and after the formatter is called.
;
;WRITING YOUR OWN FORMAT FUNCTIONS
;
;The easiest way to specify a special output format is through a template
; installed as the #GRIND-TEMPLATE property of some atom.
; However this may not be flexable enough in some situations. You can
; get complete control over how something is formated by writing your
; own format function. The resulting format function can be installed
; as the #1GRIND-FN property of some atom, or can be SETQed as the value
; of one of the atoms #1format-dispatch, #1format-list, #1format-hunk,
; or #1format-atom. (#1format-dispatch is a somewhat special case.)
; Any format function must follow all of the requirements set forth
; above. There are several mechanisms for assisting you in writing
; format functions.
;
;In order to write your own format functions, you should study the format
; functions included in the #printer.
;
;The macro #MAKE-INVERT-QUOTE-FN constructs formatting functions which do
; simple read macro inversion. for example
; (#make-invert-quote-fn quote /')
; (which is part of the basic #print package) builds a formatting
; function which outputs "(quote foo)" as "'foo". In order to see how
; this works, consider a more complete example:
; (#make-invert-quote-fn list /[ /])
; this would cause "(list a b c)" to print out as "[a b c]". The macro
; produces the following formatting function:
;
(declare '| (defun (list #grind-fn) (temp item)
(setq #1open-del '/[ #1close-del '/])
(cond (#1format-list (funcall #1format-list temp (cdr item)))
((#1format-list temp (cdr item))))) |)
;
; This uses the variables #1OPEN-DEL and #1CLOSE-DEL in order to change
; the delimeters of the thing being formated and then formats the cdr of
; the thing. (if there is no close delimeter specified in the macro
; call (as in the QUOTE example), then a null close delimiter is
; assumed.) Note that the formatting function produced follows the
; convention that the variable #1FORAMT-LIST may contain a user
; redefinition of the default list formatting function.
;
;The function #MAKE-INVERT-QUOTE-FN2 is basically very similar except that it makes the basic
; assumption that the relavent value is the CDR instead of the CADR.
; as a result of this, there is no case corresponding to having both an open
; and a close delimiter. Rather you merely specify an atom which is printed
; before the CDR which is otherwise printed normally. for example:
; (#make-invert-quote-fn2 '|`-expander/|| '|`|) (which is part of the
; standard printer environment along with handling "," ",@" and ",.")
; causes (|`-expander/|| a b c) to print out as `(a b c)
;The lsubr #1FORMAT-LSUBR is available in order to asisst you in writing
; format functions. Templates allow you to specify the fcodes to use.
; #1FORMAT-LSUBR allows you to additionally specify what objects to
; print and what order to print them in. This could be done by consing
; up a list of the things you wanted printed and then calling
; #1FORMAT-LIST. #1FORMAT-LSUBR allows you to get this effect without
; actually consing up the list. As such it is essentially used for
; efficiency. #1FORMAT-LSUBR could have been defined as:
; (defun #1format-lsubr nargs (#1format-list (arg 1) (listify (- 1 nargs))))
; the following example shows how #1FORMAT-LSUBR could be used to help
; write a nonstandard formater for hunks:
;
(declare '| (defun special-format-hunk (temp hunk)
(cond ((eq (hunksize hunk) 4)
(setq #1open-del '/@ #1close-del '/@)
((lambda (#1prinlevel #1prinlength)
(#1format-lsubr
'(1 (never) (never)) (maknum hunk) (cxr 3 hunk)))
4 4))
(t (#1format-hunk temp hunk)))) |)
;
; If you did a (setq #1format-hunk 'special-format-hunk) then whenever a
; hunk was going to be formated, the function SPECIAL-FORMAT-HUNK would
; be called. This function checks to see whether the hunk is a hunk4.
; If it is, then it prints out the maknum of the hunk and the cxr-3 of
; the hunk surrounded by @s. For example,
; (hunk 1 2 '(list zap) '(car foo)) would print out as
; "@123456 (list zap)@" if 123456 was the maknum of the hunk.
; Note that special-format-hunk binds #1prinlevel and
; #1prinlength in order to control the amount of abbreviation which will
; apply. If it hadn't bound them, then the abbreviation would have been
; a function of the depth of the hunk in the structure being printed.
; as it is it is always the same. If the hunk is not a hunk4 then the
; standard hunk formater is called in order to format the hunk.
;Using #1FORMAT-LSUBR implies that the standard formatting conventions
; described above will be used. If you want to do something complete
; original, you can write a format function which directly calls
; #1ENTER-OBJ. An example of the is (PROG #GRIND-FN) which is defined
; in the standard #printer. It is basically like #1FORMAT-LIST except
; that it prints the tags properly. This is also used to print DOs.
; There is also a little #GRIND-FN for DEFUN which makes it print out
; right in both 2 and 3 argument form.
;
;consider the following more detailed example.
(declare '(defun foo #grind-fn (unused-temp list)
(#1enter-obj 1 nil 'start)
(#1enter-format&obj 'never 0 (cadr list) 'prin1 nil)
(cond ((not (null (caddr list)))
(#1enter-format&obj 'never 0 '/- 'princ nil)
(#1enter-format&obj 'never (caddr list) 'prin1 nil)))
(#1enter-format&obj 'never 1 '/: 'princ nil)
(#1enter-format 'normal 0)
(#1format-dispatch nil (cadddr list))
(#1enter-format&obj 'never 0 '|| nil 'end)) )
;this directly calls #1enter-obj for five reasons: it uses non standard
; delimiters (in fact no open and close delimiters at all), it uses non-standard
; bcodes, it inserts certain internal delimeters (: and -), it does
; different things based on what the structure of the item is (ie
; whether or not the 3rd list ellement is nil), and it doesn't print the
; first item of the list at all, that just exists in order to get to the
; correct printout formatter. In GRIND mode,
; '(foo 1 2 3) would print as:
; "1-2: 3"
; '(foo 1 nil 3) would print as:
; "1: 3"
;IMPLEMENTATION NOTE ON SECTION 4,
;SPECIAL ATOMS USED BY THE FORMATTING FUNCTIONS:
;
;there are a set of special variables and properties which are used by the
; formatting functions either internally, or for control from the
; outside. this list describes EVERY special variable which is
; referenced by a format function, or is considered available to be
; looked at by a format function. (variables which are not actually
; used by the standard formaters are preceeded by a *.) These variables
; are divided into catagories even though there is really some logical overlap.
;
;variables passed down from #1PRINTER which describe how a thing will be formated.
; #1checkrecursion - (t/nil) if NIL, this enhibits the function #1rcheck from checking
; for circularity in objects being formated.
;*-#1prinlevel - (a non-negative number) The depth in a structure at which the formaters should
; abbreviate non-atomic substructures by inserting |#| in place of the
; substructure. This is not acutally looked at because the same information is
; indirectly encoded in the variable #1level (see below).
; #1prinlength - (a non-negative number) The maximum number of things to
; print out at any one level. if there are more that this many things at a
; given level, the |...| is printed out in place of the remainder. (actually if
; there is only 1 to many things, and the extra one is an atom, then the
; structure prints out unabbreviated.)
;*-#1prinstartline - (a non-negative number) This is the line number of the
; first line to print out. This is actually not used by the formaters, but it
; is available. (#1printout implements this abbreviation facility.)
;*-#1prinendline - (a non-negative number) This is the line number of the last
; line to print out. This is actually not used by the formaters, but it is
; available. (#1printout implements this abbreviation facility.)
;*-#1prinmode - (a template) This is the top level template to use for formatting the
; current thing. This is not actually used because it is passed as the
; first argument to the top level call of the format functions.
; #1princ-atoms - (t/nil) if non-NIL then individual atoms in the object to be
; formated. are marked so that they will be PRINCed instead of PRIN1ed.
; 1st argument to #1format-dispatch (and all other formatting functions) - (a
; template) this is a template which is used to guide the formatting of
; the object. The top level call of #1format-dispatch is passed the
; value of #1prinmode. Only #1format-dispatch can take a null template.
; 2nd argument to #1format-dispatch (and all other formatting functions) - (an
; arbitrary object) the object to be formated. #1formt-dispatch takes an
; object of any type. the others take restricted types as their names imply.
;variables which are set by the external environment and control the actions
; of the formaters.
; #grind-template PROPERTY - (a template) if an atom has a #grind-template
; property, then whenever #1format-dispatch is given a null template and
; a list whose car is that atom, then that template will be used to
; format the list.
; #fn-grind-properties - (a list of property names) if an atom doesn't have a
; #grind-template property, but it does have one of the properties in
; this list, then whenever #1format-dispatch is given a null template
; and a list whose car is that atom, then a template which causes
; grinding in functional form will be used to format the list.
; #1default-symbol-car-grind-template - (a template) if #1format-dispatch is
; given a nil template and a list with an atomic car, and neither of the
; above two cases applies, then this template will be used to format the list.
; #1apply-template - (a template) this template is used in GRIND mode to
; format lists whose cars are lambda expressions.
; #1default-non-symbol-car-grind-template - (a template) if #1format-dispatch
; is given a nil template and a list with a non-atomic car which is not
; a lambda expression, then this template will be used to format the list
; #grind-fn PROPERTY - (a formatting function) if an atom has a #grind-fn
; property, then whenever #1format-dispatch is given a null template and
; a list whose car is that atom, then that formatting function will be used to
; format the list.
; #1format-dispatch - (a formatting function or nil) if non-nil this function
; is called whenever #1format-dispatch whould have been.
; #1format-list - (a formatting function or nil) if non-nil this function
; is called whenever #1format-list whould have been.
; #1format-hunk - (a formatting function or nil) if non-nil this function
; is called whenever #1format-hunk whould have been.
; #1format-atom - (a formatting function or nil) if non-nil this function
; is called whenever atoms are to be formated.
;variables which are used for internal communication between the formatting
; functions. All of these variables must be initialized before calling
; any format functions (this is done by #1format-init).
; #1parents - (a one dimensional array) This is used by #1rcheck in order to
; remember what cons cells have already been formated, so that it can
; detect circularity.
; #1rsize - (the length of the array in #1parents) This is used by #1rcheck
; in order to check that it is not overflowing the array #1parents. It
; automatically extends the array if it needs to.
; #1rindex - (a non-negative number less than #1rsize) This is the index of
; the first free slot in #parents. It is incremented by #1rcheck
; whenever it adds a new entry into #1parents. It is the responcibility
; of the formatting functions which call #1rcheck to decrement the value
; of #1rindex. The easiest way to do this is for each format function to
; remember the value of #1rindex on entry, and restore this value on exit.
; (this works as long as the pattern of calls and returns of the format
; functions mirrors the tree like strucutre of the object being printed.)
; (initialized to zero)
; #1level - (a non-negative number) This counts down from #1prinlevel to
; zero. When it reaches zero, the format functions do prinlevel
; abbreviation. Each format function which corresponds to a level on
; nexting, should decrement #1level on entry, and increment it on exit.
; (initialized to #1prinlevel)
; #1open-del - (nil or a thing to be PRINCed as an open delimeter) If this is
; non-nil then it causes just one substructure to use it as the open
; delimiter. The one which uses it is the one corresponding to the
; temporally first call of a substructure formater after #1open-del is
; set. The substrucutres of this structure will use the normal
; delimiters. (initialized to NIL)
; #1close-del - (nil or a thing to be PRINCed as a close delimeter) this is
; just the same as #1open-del but for the close delimiter.
;
;variables which are used for communication between the formaters and
; #1ENTER-OBJ
; #1fcode - (one of {never normal tblock block always}) this says when to put
; a crlf before the next thing to print. it is initialized to 'never at
; the top level.
; #1bcode - (a non-negative number) this is how many blanks to print out
; after the next thing to print. it is initialized to zero at the top
; level. (note that #1FCODE and #1BCODE can be conveniently set by
; #1ENTER-FORMAT and #1ENTER-FORMAT&OBJ.
; 1st arg of #1enter-obj - (an arbitrary object or if the 3rd arg is 'start
; then a number) this is the object to be printed at this point, it need
; not be an atom, though with the standard formaters it always is. if
; the second argument is NIL and the third argument is not 'start then
; the first argument is ignored, and there is no object to print.
; 2nd arg of #1enter-obj - (one of {prin1 princ nil}) the code that says how
; to print the object.
; 3rd arg of #1enter-obj - (one of {start end nil}) the code that indicates
; the beginning and end of substructures.
;SECTION 5, THE FUNCTIONS #1ENTER-OBJ AND #1PRINTOUT
;
;this is the nitty gritty which takes the formatting instructions produced by
; the formatting functions and dynamically decides how the output will
; actually look. It then does the actuall output. this is the part of
; the program which is somewhat convoluted and contorted in order to get
; efficiency. it embodies the basic ideas which make this printer so
; much faster than standard GRINDEF.
; It is not intended that the user modify these two functions.
; This is in contrast to the other parts of the system which are
; explicitly intended to be modifiable. This section is included to
; make the documentation complete, and to give a more complete
; understanding of how the #printer works.
;
;above, the actions of the formatting functions were described as creating a
; sequence of calls on #1ENTER-OBJ. (Note the macros #1ENTER-FORMAT and
; #1ENTER-FORMAT&OBJ which help in this.) #1ENTER-OBJ converts this sequence
; of calls into a static data structure which is used by #1printout in
; order to do the printing. The static data object is needed because
; #1ENTER-OBJ must do some look ahead in order to figure out some of the
; information it adds into the sequence of calls.
; The sequences of calls on #1enter-obj are designed to be easy to
; make, and to have little redundancy. The data structure is designed
; to have all of the information which #1printout needs made explicit.
; The data structure follows the same basic structure as the
; sequence of calls on #1enter-obj. It has one node of information for
; each call on #1enter-obj. at each node, it has all of the information
; passed to #1enter-obj plus several other pieces of information:
; 1. the length of the object (or entire substructure)
; 2. whether of not the substructure corresponding to a node contains
; an always code within it.
; 3. whether or not the object corresponding to this node is complete.
; I.E. in the case of substructures whether or not all of the calls
; on #1enter-obj corresponding to its interior have already been
; processed, and therefor whether the pieces of information described
; in 1, and 2 are really accurate yet. Until the item is complete these
; pieces of information are only partially true. (Note however, that
; they are monotonic. Ie they length can only increase as more is known,
; and 2 & 3 can only go from false to true.)
; Note that each of these additional pieces of information is summary
; information about a number of nodes which combine to form a
; substructure. A number of nodes must be saved up in order to complete
; the calculation associated with a given node. (in the limit this
; implies that the information (for example the length) associated with
; the very first node (which is a substructure starting node for the
; whole thing to be printed) cannot be complete until all of the nodes
; have been created.
; This would lead to a large use of storage if it weren't for one
; very important fact. The function #1PRINTOUT is often able to decide
; what it will do with a node before it has complete information about
; the node. This is due to the monitonic nature of these fields. For
; example, #1ENTER-OBJ continually updates the length fields as new
; nodes are created. #1PRINTOUT can decide that a given substructure is
; too long to fit on one line as soon as its length gets longer than the
; line length. It does not have to wait until it knows what the actual
; complete length is. this allows early nodes to be processed even
; before they are complete constructed. (It turns out that whether
; something is too long for a line is the basic thing which #1PRINTOUT
; needs to know, and as a result the system only needs to have at one time
; the nodes which correspond to roughly one line of output. This is
; true even if the thing printing out ends up taking up hundreds of lines)
;An important efficiency comes from the fact that #1PRINTOUT processes nodes
; in the data structure in a purely first in first out order. this
; allows them to be stored in a queue. as each node is created it is
; added into the queue, and #1ENTER-OBJ updates the information
; associated with the other nodes still in the queue. when one
; is processed it is dropped form the queue, and #1ENTER-OBJ no longer
; tries to compute updated information for it.
; A very big savings comes from the fact that this queue is
; implemented in arrays in such a way that no CONSing is done. This
; prevents the #printer from creating garbage collections. These arrays
; are managable in size beacuse the number of nodes that must be
; remembered at once is a function of the line length and NOT of the size
; of the thing being printed (as discussed above).
; (this queue is not implement as a ring buffer wrapping around in
; the array, but rather by just shifting things over in the array when
; the queue strikes one end. This at first appears time inefficient,
; however, since the queue never gets very long, the time lost in
; shifting is more than made up for by the time saved in testing whether
; the queue is empty, and poping ellements off of the queue.)
;
;For storage efficiency, the information associated with each node is crammed
; into three cells:
; 1. (referred to as LENGTH) holds a number which is the length of the
; object associated with the node.
; 2. (referred to as OBJECT) holds the object or indentation code
; associated with the node.
; 3. (referred to as FLAGS) holds the blank code and all of the binary
; flags packed together as bits. a set of macros are used to set and
; check these bits.
;
;The function #1SET-UP-MACROS if exicuted creates all of the macros needed for
; in compilation or running these functions uncompiled. Otherwise, the
; macros are not defined when you fasload in #print. A function DECODE
; is also defined by #1SET-UP-MACROS. This function is a debugging aid.
; It decodes the bits in FLAGS into a more readable form.
; There are two basic macros which get defined. FLAGS is a macro
; which builts up FLAGS entries. It takes numbers, things which
; evaluate to numbers and quoted keywords from the list
; {always normal block tblock never princ prin1 list-start list-end
; complete inner-always}.
; It creates code which builds a FLAGS entry. for example:
; (flags 1 'never 'list-start (foo))
; creates a FLAGS entry which has a blank code of 1, a format code of
; 'never, is the starting node for a substructure, and which also has
; all of the bits set corresponding to the FLAG returned by (foo).
; A set of macros is produced for querying these bits. the set
; {always? normal? block? tblock? never? princ? prin1? list-start? list-end?
; complete? inner-always?} test for the presence of the corresponding
; flags. The macro BCODE returns the number corresponding to the blank
; code of a FLAGS entry.
;#1enter-obj performs several tasks:
; 1. It combines the variables #1FCODE #1BCODE, and its second and third
; arguments into a FLAGS entry. (Note that these variables can be
; conveniently set by #1ENTER-FORMAT and #1ENTER-FORMAT&OBJ.)
; 2. As part of this it takes the bcode associated with a list-start node
; and puts it on the last node in the substructure. this is done
; because it is more logical to state the bcode when starting the
; structure, but more conventient for #1PRINTOUT to have it at the end
; (which is after all where the blanks get printed). In order to do
; this #1ENTER-OBJ uses a stack implemented in a vector #1BCODESTACK and
; using a pointer #1SUPPTR. The stack is needed in order to remember
; the bcode from the time it is first available until the time it is
; needed.
; 3. It computes the length of each atomic node (those which aren't
; list-start nodes) and puts that as the length of the node and adds it
; into the length of all of the list start nodes which are its superiors
; (except those which have already been taken off the queue). The
; list-start nodes start out with length zero. The length of an atomic
; node is the bcode plus the flatsize (or flatc) of the object to print
; (if there is one). The vector #1SUPSTACK is used to keep a stack of
; the superiors of the current node. the stack contains numbers which
; are the differences between the positions in the queue of succeeding
; superiors. differences are used because they remain correct when the
; queue is shifted over. the pointer #1SUPPTR is used as the stack
; pointer since #1SUPSTACK and #1BCODESTACK go up and down in synchrony.
; 4. If any node has an ALWAYS flag, then #1ENTER-OBJ sets the INNER-ALWAYS
; flag on in each superior.
; 5. #1ENTER-OBJ sets the COMPLETE flag on in each atomic node, and with
; each list-end node, it marks the corresponding list-start, complete.
; 6. Internally it maintains #1SUPSTACK and #1BCODESTACK for its own use.
; this amounts to pushing each list-start node and doing a pop for each
; list-end node. In addition #1ENTER-OBJ extends the vectors if they
; ever prove to be too short. #1SUPSIZE holds their length for easy
; reference.
; 7. it enters each of these objects into the queue. the queue is
; implemented by three vectors: #1OBJ, #1FLAG and #1LENGTH and two
; pointers: #1INPTR which points to the insertion point and #1PP which
; points to the removal point (the head of the queue). These vectors
; are extended if they prove too small. the variable #1SIZE holds the
; length of these vectors for easy reference.
; 8. if the variable #1EXPLODING is non-nil then instead of queueing up the
; nodes, #1ENTER-OBJ just NCONCs up the EXPLODEs of the objects in the
; atom nodes in the variable #1EXPLODE-RESULT. NRECONC is used, so that
; #1EXPLODE-RESULT can simply be NREVERSed in order to get the result.
; 9. if #1EXPLODING is nil then #1ENTER-OBJ calls #1PRINTOUT each time a
; new node is added in order to see whether it has enough information to
; do something.
;the following example shows the static data structure built up corresponding
; to the example from section 2:
(declare `|"(list (cons var1 var2) var3 var4)" leads too:
fcode bcode obj pcode lcode length inner-a complete
1 'never _ 6 nil 'start 33 nil t
2 'never 0 '/( 'princ nil 1 nil t
3 'never 1 'list 'prin1 nil 5 nil t
4 'never _ 6 nil 'start 17 nil t
5 'never 0 '/( 'princ nil 1 nil t
6 'never 1 'cons 'prin1 nil 5 nil t
7 'never 1 'var1 'prin1 nil 5 nil t
8 'normal 1 'var2 'prin1 nil 4 nil t
9 'never 1 '/) 'princ 'end 2 nil t
10 'normal 1 'var3 'prin1 nil 5 nil t
11 'normal 0 'var4 'prin1 nil 4 nil t
12 'never 0 '/) 'princ 'end 1 nil t |)
;this is as you would see it left in memory after printout was complete. all
; of the complete bits have been turned on, there are no inner-always,
; the lengths have been computed, the bcodes have been moved from the
; list-start nodes to the corresponding list-end nodes. The section
; above which discusses calls on #1ENTER-OBJ discusses how the above
; sequence would be interpreted in order to print the list out.
;The function #1PRINTOUT acts like an interpreter for the data structure built
; up by #1ENTER-OBJ. Each time it is called it looks at the first
; element in the queue and decides whether or not it can do something
; with it. If it can do something it loops back and calls itself
; again. If not it just exits.
; 1. it first checks to see if the queue is empty, if so, it just exits.
; 2. It then checks to see if it is possible that it might have to tab in
; front of the next node (ie if it has a TBLOCK fcode and is complete).
; If this is the case, and if it hasn't already figured out what the size of
; tabs will be (the variable #1TABSIZE is 1) then It figures out what the size
; of tabs will be. It does this by looking at the length of the current node
; and the following nodes at the same level. It takes the max of all their
; lengths. However, it realizes that it may not have seen all of the subnodes
; which are supposed to be printed in columns and therefor this maximum may not
; be long enough to insure that all of the nodes will line up nicely when
; printed out. In order to make a more conservative estimate of the spacing
; required, it first raises its estimate by 20%, and then rounds it
; up to the largest integer which divides the available line length the same
; number of times. To do this it uses the properties of integer arithmitic and
; the expression:
; x = (// linelength (// linelength x))
; For example if the maximum node in view is 11 and the available line
; length is 62 (for example, the line length is 95 and this substructure
; starts in column 33). first the max would be increased by 20% to 13 and then it
; would be increased to 15 since 13 goes into 62 4 times, and 15 is the
; largest integer which goes into 62 4 times.
; Having computed the tab size, #1PRINTOUT then computes an offset
; in the variable #1TABOFFSET. this is done because the space remaining
; on the line may not be a multiple of the tab size. (In the example
; above the offset is 2.) How far to tab in a given situation is
; computed by the expression:
; (\ (- space-remaining #1taboffset) #1tabsize)
; (there is a bug in this if the space remaining ever gets less than
; #1TABOFFSET. In this case, the remainder function has a negative first
; argument and doesn't do what you would like. To fix this the offset
; stored in #1TABOFFSET is actually (- offset #1TABSIZE) this is just
; the same from the point of view of modular arithmetic and has the
; virtue that it is always negative.)
; 3. next #1PRINTOUT checks to see whether it needs to insert a crlf at the
; current point. In doing this it checks whether the last thing is did
; was to put out a crlf. if so, then it never puts out another one.
; then if the next thing needs to be tabbed in front, it checks to see
; whether enough spaces have been put out. Finally it looks at the
; fcode and sees whether it implies that a crlf whould be inserted. (See
; above for a deiscussion for what the fcodes mean.)
; 4. if a crlf is needed, then it is put out and blanks are printed in
; order to space over to the correct indentation column. the
; indentation codes in the calls to #1ENTER-OBJ are used in order to
; know what column to tab too. the indentation columns are remembered in
; a stack implemented by a vector in #1INDSTACK and the pointer
; #1INDPTR. (See below for how the indentation points are calculated.)
; This section implements #1prinstartline-#1prinendline
; abbreviation. a variable #1printing? is used as a flag which controls
; whether any actual output is ever done. Each time a crlf is to be
; performed #1PRINTOUT checks to see whether the state of this flag
; should be changed. if #1prinendline is reached, then #1PRINTOUT does
; a throw in order to abort the #printing.
; 5. Now #1PRINTOUT knows that if a crlf is needed before the next thing,
; it has already been put out. it now looks at the next thing to be
; printed out. there are three cases:
; 6. the next item is a substructure whose length as currently computed is
; already too long to fit in the space remaining on this line. In this
; case, #1PRINTOUT looks inside this structure in order to print it on
; more than one line. to do this, it simply moves over the header node
; and computes the new indentation column. the new indentation is
; computed by adding the indentaion count in the header cell to the
; current column possition. if the resulting indentation is less than
; the initial starting column position (kept in the variable #1CP) then
; it is increased to that. this is waht prevents the #printer from ever
; printing to the left of where it starts. if it is greater than the value of
; #1MAXINDENTLEN (which is initialized to 80% of the available line length) then
; it is reduced by 60% of the available line length. this keeps output
; from getting so pushed up against the left margin that there isn't enough
; room to print the individual atoms in the structure. an abrubt
; change in indentation is produced which tends to be rather ugly, but
; which is clearly understandable and saves the #1printer from disaster.
; The new indentation level is pushed onto the stack #1INDSTACK.
; (#1PRINTOUT does not have to check for overflow in this vector,
; because #1ENTER-OBJ extends it to be as long as #1SUPSTACK. The
; latter is as long as the maximum number of levels in the structure
; being printed. as a result #1INDSTACK can't overflow even if
; #1PRINTOUT has to look inside the deapest structure in the thing being
; printed.)
; In addition #1TABSIZE is set to 1 which indicates that it is
; unitialized. It will be recaluclated for this new level if needed.
; 7. alternatively, the next node may not be too long to fit and may be
; complete. if this is the case then it is printed out. #1PRINTOUT
; counts header nodes and LIST-END nodes in order to see when it has
; printed out all of the things associated with the initial node. If
; the first node encountered by #1PRINTOUT is a LIST-END node then
; #1PRINTOUT prints it out and pops up a level in the structure being
; printed. when it does this, it sets #1TABSIZE to 64000. which has the
; effect of preventing continued tabbing at the level popped back to.
; Logically #1PRINTOUT should keep a stack of tab sizes, so that it
; could continue tabing when it pops back out of a substructure.
; However, it was decided that if one of the substructures in a
; structure being printed with tabbing takes more than one line, then
; tabbing should not continue at that level. This was done because
; experimentation showed that continued tabbing made it harder to
; understand what was being #printed.
; 8. often neither 6 or 7 is true, in that case, #1PRINTOUT just does
; nothing and returns to #1ENTER-OBJ in order to get more information.
; 9. if either 6 or 7 was true then #1PRINTOUT loops back to the top in
; order to see whether it can do anything more.
;IMPLEMENTATION NOTE ON LEVEL 5
;SPECIAL VARIABLES USED BY #1ENTER-OBJ AND #1PRINTOUT
;
;a large number of these variables (particularly the ones which are internal
; to theis part of the package) are initialized by the function #1FORMAT-INIT.
;
;variables which are used for communication between the formaters and
; #1ENTER-OBJ:
; #1fcode - (one of {never normal tblock block always}) this says when to put
; a crlf before the next thing to print. it is initialized to 'never at
; the top level.
; #1bcode - (a non-negative number) this is how many blanks to print out
; after the next thing to print. it is initialized to zero at the top
; level. (note that #1FCODE and #1BCODE can be conveniently set by
; #1ENTER-FORMAT and #1ENTER-FORMAT&OBJ.
; 1st arg of #1enter-obj - (an arbitrary object or if the 3rd arg is 'start
; then a number) this is the object to be printed at this point, it need
; not be an atom, though with the standard formaters it always is. if
; the second argument is NIL and the third argument is not 'start then
; the first argument is ignored, and there is no object to print.
; 2nd arg of #1enter-obj - (one of {prin1 princ nil}) the code that says how
; to print the object.
; 3rd arg of #1enter-obj - (one of {start end nil}) the code that indicates
; the beginning and end of substructures.
;
;Variables which are used to communicate between #1PRINTER and #1ENTER-OBJ:
; #1exploding (t/nil) if T then #1PRINTOUT is not actually called, and the
; EXPLODEs of the nodes is consed up and returned instead.
; #1explode-result (a list of characters) if #exploding, this is used to
; accumulate the nreverse of the result in.
;
;Variables which are used to communicate between #1PRINTER and #1PRINTOUT:
; #1prinendline (a non-negative number) this says what line to stop printing
; on. when this line is reached a throw is done to terminate #printing.
; #1prinstartline (a non-negative number) this says what line to start
; printing on. Until this line is reached, nothing is actually printed out.
; #1cp (a non-negative number) this is the column position where #printed was
; initiated. #RINTOUT takes pains not to print ot the left of this
; point. it is treated as the defacto zero point for the left margin.
; this is initialized by #1FORMAT-INIT to (CHARPOS #1MAINFILE).
; #1linelen (a non-negative number) this is (- (LINEL #1MAINFILE) 5) the -5 is
; done in order to make closing parentheses come out in the right place a
; higher percentage of the time. this is used to figure out how much
; space is left on the current line being printed on.
; #1maxindentlen (a non-negative number) this is point 80% of the way from
; #1CP to #1LINELEN and is used to limit the total amount of indentation allowed.
; #1files (a list of files) this is used as an argument to PRINC PRIN1 TERPRI
; and TYO in order ot control where the output goes to.
;
;Variables used by #1ENTER-OBJ to communicate with itself:
; #1bcodestack (a vector of fixnums) this holds the bcodes which are specified
; at the start of substructures until they are used at the end of the substructure.
; #1supstack (a vector of fixnums) this holds differences which can be used to
; find the nodes which are the superiors of the current node.
; #1supptr (a fixnum pointer into the above two vectors) this is used to make
; a stack out of the above.
; #1supsize (the size of the above two vectors) this holds the size of the
; above vectors and #1indstack below (which are automatically extended if need be).
;
;Variables used for communication between #1ENTER-OBJ and #1PRINTOUT:
; #1obj (a vector of objects) the object at a node
; #1flag (a vector of flag bits crushed into fixnums) the flag bits for a node.
; #1length (a vector of fixnums)the length of each node.
; as discussed at length above, these three vectors form a queue holding
; the information at each node of the intermediate structure built up by
; #1ENTER-OBJ.
; #1inptr (a pointer into the above three vectors) the insertion point in the
; above queues.
; #1pp (a pointer into the above three vectors) the removal point in the above
; queues.
; #1size (the size of the above three vectors) this holds the size of the
; above vectors (which are automatically extended if need be).
;
;Variables used by #1PRINTOUT to communicate with itself:
; #1cline (a non-negative number) this is the relative line number of the
; place where #1PRINTOUT is currently printing. this is what is compared
; with #1prinendline and #1prinstartline.
; #1freelen (a number) this is the amount of free space left at the end of the
; current line. the current charpos on that line is (- #1linelen #1freelen).
; #1pending (a non-negative number) this is the number of blanks which should
; be printed before the next thing. #1PRINTOUT never prints any blanks
; until it absolutely has to, rather it just increments #1PENDING. this
; allows it to simply avoid printing blanks at the end of a line.
; #1tabsize (a non-negative number) this is the current size for tabbing (see
; the discussion above). The value 1 indicates that the correct tab size
; has not yet been calculated.
; #1taboffset (a negative number) This is used in conjunction with #1TABSIZE
; (see the discussion above).
; #1atstart? (t/nil) this flag is used by #1PRINTOUT in order to quichly check
; whether or not it is at the start of a line. ie whether th e last
; thing it did was to do a crlf or not.
; #1wentup? (t/nil) this is T if the last thing #1PRINTOUT did was to pop up
; out of a lower structure. this is used in conjunction with BLOCK and
; TBLOCK modes.
; #1printing? (t/nil) this is nil when #1cline is less that #1prinstartline
; and therefor actual printout is being supressed.
; #1indstack (a vector of numbers) this is a stack which is used to keep the
; indentation points associated wiht the different levels in the
; structure being printed. each indentation is greater than or equal to
; #1cp and less than of equal to #1maxindentlen.
; #1indptr (a pointer into the above vector) this is used to implement a
; stack in #1indstack.
;these are all declarations and macro definitions
(declare (fasload util fasl dsk dick) (u1setupreader)
(fixnum i j k n length end rindex max default-bcode bcode space level flags)
;system special variables which are looked at, never bound, and never assigned to
;(except that some of them may be given initial values at load time if they are unbound)
;most of these are used in order for the user to comunicate with the printer.
(special #checkrecursion prinlevel prinlength prinmode prinendline
prinstartline ^r ^w outfiles grindef grindproperties #fn-grind-properties
#1default-symbol-car-grind-template #1default-non-symbol-car-grind-template
tyo #1format-dispatch #1format-list #1format-atom #1format-hunk grind-macroexpanded)
;special variables which are used by the system to communicate with itself. they
;are rebound in order to save a state of the system, and are set up by #1format-init
;these should not be changed by the user unless he really knows what he is doing.
(special #1prinlevel #1prinlength #1prinendline #1prinstartline
#1cp #1linelen #1maxindentlen #1cline #1freelen #1pending #1tabsize
#1taboffset #1inptr #1pp #1supptr #1indptr #1size #1supsize #1rsize
#1prinmode #1checkrecursion #1mainfile #1truncated #1files
#1atstart? #1wentup? #1printing? #1obj #1flag #1length #1supstack
#1indstack #1parents #1nowprinting #1fcode #1bcode #1bcodestack
#1level #1rindex #1open-del #1close-del #1princ-atoms #1print-like
#1exploding #1explode-result)
;special variables which are used to hold system constants (they should never be modified)
(special #1miser-template #1block-template #1crush-template #1fn-template
#11level-block-template #1defun1-template
#1defun2-template #11level-tblock-template
#1apply-template #11level-miser-template #1tblock-template)
(*lexpr #prin1 #print prinl prinl1))
(declare (@define deffn))
;this file makes heavy use of the macros in the file util > dsk dick. for those who
;do not like to read macros like these, a completely macro expanded version of #print
;is included at the end of the file. that version contains no macro calls,
;and is guarrenteed to be accurate (in fact, the fasl file is actually a compilation of the
;the macro expanded version). As long as I maintain this file I will work with the
;macro version and keep the expanded version correct.
;these macros are here in order to satisfy the compiler,
;they logically belong with #1enter-obj
(deffn #1enter-format macro keep displace [_ f b]
`(setq #1fcode ,f #1bcode ,b))
(deffn #1enter-format&obj macro keep displace [_ f b o p l]
`(progn (#1enter-format ,f ,b)
(#1enter-obj ,o ,p ,l)))
;this is used to construct a fn #1set-up-macros which can be run at any time
;in order to define all of the macros which are needed for any of the functions
;below can be run interpretively. This gives you access to the macros without
;having them always defined.
(decl
(deffn build-#1set-up-ms macro []
(let ((#encodings '((always 64.) ; 000 100
(normal 128.) ; 000 200
(block 256.) ; 000 400
(never 512.) ; 001 000
(tblock 1024.) ; 002 000
(princ 2048.) ; 004 000
(prin1 4096.) ; 010 000
(list-start 8192.) ; 020 000
(list-end 16384.) ; 040 000
(complete 32768.) ; 100 000
(inner-always 65536.)))) ; 200 000
['deffn '#1set-up-macros '[]
!(over '((#1obj nil) (#1flag fixnum) (#1length fixnum) (#1supstack fixnum)
(#1indstack fixnum) (#1parents nil) (#1bcodestack fixnum))
-> [atom type] nconc
`((deffn ,atom macro displace [!from]
`(arraycall ,',type ,.(copy from)))
(deffn ,atom u1<- [to]
`((store ,to u1f) nil))))
'(deffn call macro displace [_ fn ! args]
`(if ,fn (funcall ,fn ,.args)
el (,fn ,.args)))
'(deffn bcode macro displace [_ x]
`(boole 1. 63. ,x))
!(over #encodings -> [name code]
list `(deffn ,(catenate name '?) macro displace [_ x]
`(not (zerop (boole 1. ,',code ,x)))))
;there are three different kinds of arguments to FLAGS. literal numbers, something that
;evaluates to a number, and quoted atoms from the list of flag names in #encodings
(subst #encodings 'encodings
'(deffn flags macro displace [_ ! args]
(begin (sum <- 0
body <- (over args -> arg
nconc (if (numberp arg)
(<- sum (+ sum arg))
nil
ef (or (atom arg) (not (eq (car arg) 'quote)))
[arg]
el;(eq (car arg) 'quote)
(let ((val (cadr (assq (cadr arg) 'encodings))))
(if (null val) (error '|bad code to FLAGs| args))
(<- sum (+ sum val)))
nil)))
(if (not (zerop sum)) (<- body [sum ! body]))
(if (null body) ''0
ef (null (cdr body)) ['progn ! body]
el ['+ ! body]))))
(subst #encodings 'encodings
'(deffn decode [x]
[(bcode x)
!(over 'encodings -> [name code]
select (not (zerop (boole 1. code x)))
list name)]))])))
(decl-double (build-#1set-up-ms))
(decl (#1set-up-macros))
;the basic printer produces output under the control of a template.
;(yet another simple programming language)
;the template conforms to the following grammer:
;
; template := explicit-temp v NIL
; explicit-temp := ( indent-count item-temp*n )
; indent-count := number v NIL
; item-temp := ( {NEVER v ALWAYS v NORMAL v BLOCK v TBLOCK} . template )
;
;if a template is NIL then the printer looks at the item to be printed in order to figure
;out what the template should be. if an indent count is NIL then (+ 2 (flatsize of the head of
;the list being printed)) is used as the indentation (this is functional form indentation).
;
;the printer carcdrs down the template and the item being printed in order to decide
;what format codes and indentation codes to use at each point.
;It has internal conventions for what the other flag fields will be.
;
;the average template is a very circular structure so that it can work on structures of
;arbitrary depth and circularity. the following function is included in order to make it
;easier to construct these circular structures. the argument to #make-template is a list
;which may contain elements of the form (^ . n) (as cars or cdrs). each of these is RPLACed
;by its nth parent in the list structure. for example:
;(SETQ X (#MAKE-TEMPLATE '(FOO (^ . 2) BAR . (^ . 1))))
;would produce an x such that (eq x (cadr x)) and (eq (cddr x) (cdddr x))
;x has the form (foo (foo (foo ...) ...) bar bar bar ...)
;note that #print whould print x out as (foo ^2 bar ^1) if #checkrecursion was non-null.
;
;note that this does not destroy its argument, and works even if its argument is circular.
(deffn #make-template [pattern]
(#make-template1 pattern nil nil))
(deffn #make-template1 [pattern oldbacklist newbacklist]
(if (atom pattern) pattern
ef (memq pattern oldbacklist)
(over oldbacklist until nil -> old
over newbacklist until nil -> new
(if (eq old pattern) (return new)))
ef (eq (car pattern) '^)
(over newbacklist until nil -> new
over icount <- (1- (cdr pattern)) by (1- icount) until nil
(if (zerop icount) (return new)))
el (let ((newcons (ncons nil)))
(pushonto oldbacklist pattern)
(pushonto newbacklist newcons)
(rplaca newcons (#make-template1 (car pattern) oldbacklist newbacklist))
(rplacd newcons (#make-template1 (cdr pattern) oldbacklist newbacklist))
newcons)))
;these are the basic templates which are used to implement the five basic printing
;modes MISER, CRUSH, BLOCK, TBLOCK, and the functional and block forms of GRIND.
(deffn #1set-up-templates []
(<- #1miser-template
(#make-template '(1 (never . (^ . 3)) (normal . (^ . 4)) . (^ . 1)))
#1crush-template
(#make-template '(-900 (never . (^ . 3)) . (^ . 1)))
#1block-template
(#make-template '(1 (never . (^ . 3)) (block . (^ . 4)) . (^ . 1)))
#1tblock-template
(#make-template '(1 (never . (^ . 3)) (tblock . (^ . 4)) . (^ . 1)))
#1fn-template
(#make-template '(nil (never) (never) (normal) . (^ . 1)))
#11level-miser-template
(#make-template '(1 (never) (normal) . (^ . 1)))
#11level-block-template
(#make-template '(1 (block) . (^ . 1)))
#11level-tblock-template
(#make-template '(1 (tblock) . (^ . 1)))
#1default-symbol-car-grind-template #1fn-template
#1default-non-symbol-car-grind-template #11level-miser-template
(get 'lambda '#grind-template)
(#make-template '(2 (never) (never . (1 (block) . (^ . 1)))
(normal) . (^ . 1)))
#1apply-template
(#make-template '(1 (never) (block) . (^ . 1)))
(get 'setq '#grind-template)
(#make-template '(nil (never) (never) (block) (always) (block) . (^ . 2)))
(get 'cond '#grind-template)
(#make-template '(nil (never) (never . (1 (never) (normal) . (^ . 1)))
(always . (1 (never) (normal) . (^ . 1)))
. (^ . 1)))
#1defun1-template
(#make-template '(2 (never) (never) (never) (normal) . (^ . 1)))
#1defun2-template
(#make-template '(2 (never) (never) (never) (never) (normal) . (^ . 1)))))
(#1set-up-templates)
;this checks that the special variables which control formatting are bound
;(the rest of the system assumes that they are bound) It gives them default
;values if they were not bound
(deffn #1set-up-globals []
(<- #1truncated nil)
(over '((prinlevel nil)
(prinlength nil)
(prinmode grind)
(prinstartline nil)
(prinendline nil)
(#checkrecursion nil)
(#fn-grind-properties (expr fexpr macro subr lsubr fsubr array autoload))
(grindproperties (expr fexpr macro))
(grindef nil)
(#1format-dispatch nil)
(#1format-list nil)
(#1format-hunk nil)
(#1format-atom nil)
(#1nowprinting nil)
(#1size nil))
-> [atom val]
(if (not (boundp atom))
(set atom val))))
(#1set-up-globals)
;________________________________________________________________________________
;this is available for setting up the suggested printing environment. it MUST
;BE CALLED BY THE USER if you want it to happen
(deffn #1set-up-printer []
(sstatus ttyint 19. '#printabort) ;^S stops printing
(sstatus ttyint 3. '#continue) ;^C makes it continue on
(endpagefn tyo '#1endpagefn) ;needed by ^C
(setq prin1 '#prin1)) ;makes #prin1 default printer
;this is available to free up almost all of the space taken up by the #printer.
;this really isn't very much space (binary program or otherwise)
(deffn #1rem-printer []
(if (eq (status ttyint 19.) '#printabort) (sstatus ttyint 19. nil))
(if (eq (status ttyint 3.) '#continue) (sstatus ttyint 3. nil))
(if (eq (endpagefn tyo) '#1endpagefn) (endpagefn tyo '+internal-tty-endpagefn))
(setq prin1 nil)
(over '((#1enter-format macro)(#1enter-format&obj macro)
(#make-template subr)(#make-template1 subr)
(#1set-up-templates subr)(#1set-up-globals subr)
(#1set-up-printer subr)(#1rem-printer subr)
(#prin1 lsubr)(#princ lsubr)(#print lsubr)
(#prinl1 lsubr)(#prinlc lsubr)(#prinl lsubr)
(#explode subr)(#explodec subr)(#explodel lsubr)
(grindef fsubr)(#1printabort subr)(#continue subr)
(#1endpage-fn subr)(#1printer subr)(#1format-init subr)
(#1format-dispatch subr)(#1rcheck subr)(#1format-list subr)
(#1format-lsubr lsubr)(#1format-hunk subr)
(#make-invert-quote-fn macro)(#make-invert-quote-fn2 macro)
(quote #grind-fn) (defun #grind-fn)(prog #grind-fn)(do #grind-fn)
(macroexpanded #grind-fn)
(#1set-up-macros subr)(#1enter-obj subr)(#1printout subr))
(remprop (car _) (cdr _)))
(over '(#1obj #1flag #1length #1supstack #1bcodestack #1indstack #1parents #1pobj)
(makunbound _)))
;the following are the main user functions for calling the #printer
;they are all in the form of a call on #1printer and they are all lsubrs
(defun #prin1 nargs (#1printer 0. (arg 1) (listify (- 1 nargs))))
(defun #princ nargs (#1printer 1. (arg 1) (listify (- 1 nargs))))
(defun #print nargs (#1printer 2. (arg 1) (listify (- 1 nargs))))
(defun prinl1 nargs (#1printer 4. (arg 1) (listify (- 1 nargs))))
(defun prinlc nargs (#1printer 5. (arg 1) (listify (- 1 nargs))))
(defun prinl nargs (#1printer 6. (arg 1) (listify (- 1 nargs))))
(defun #explode (obj) (#1printer 8. obj nil))
(defun #explodec (obj) (#1printer 9. obj nil))
(defun #explodel nargs (#1printer 14. (arg 1) (listify (- 1 nargs))))
;________________________________________________________________________________
;this is a rewritten version of grindef which calls prinl. it is intended to be
;exactly compatable with the old grindef as far as arguments etc.
;the variable GRINDPROPERTIES holds the default properties which will be printed
;out. additional properties can be specyfied as the first arg of GRINDEF. the printout
;format is of course a bit different as is the way you specify grind functions.
(deffn grindef fexpr [!arg]
(begin ([_ (not (atom _)) = props :!_ !atoms]
<- (if arg (<- grindef arg) el grindef)
selectedprops <- [!! props ! grindproperties])
(over atoms -> atom
(and (status feature trace) (memq atom (trace))) -> traced
(over [ind prop ! rest] <- (plist atom) by rest until (null ind)
select (and (if (and traced (memq ind '(expr fexpr macro)))
(<- traced nil)
(if (memq ind selectedprops)
(terpri) (princ '|;traced|))
nil
el t)
(memq ind selectedprops))
(if (and (not (atom prop)) (eq (car prop) 'lambda))
(prinl ['defun
! (if (eq ind 'expr) [atom]
ef (memq ind '(fexpr macro)) [atom ind]
el [[atom ind]])
! (cdr prop)]
'grind)
el (prinl ['defprop atom prop ind] 'grind)))))
'||)
;this should be put on an interrupt character i.e. (sstatus ttyint 19. '#printabort)
;it enables you to stop printing in the middle of something.
(deffn #printabort [unused-f unused-ch]
(nointerrupt nil)
(tyi tyi)
(if #1nowprinting (errset (throw '|aborted| #1printabort))))
;this allows you to continue output which was truncated because
;it was too many lines long. it is only really intended to work with output to the tty.
;this should be put on an interrupt character ie (sstatus ttyint 3. '#continue)
(declare ((lambda (obarray) (remprop (intern 'cursorpos) (intern 'acs))) sobarray))
;due to changes in cursorpos fn code.
(deffn #continue [unused-f unused-ch]
(nointerrupt nil)
(tyi tyi)
(if #1truncated
(begin ([c1truncatepos c1cp c1mainfile c1code c1obj
[_ _ _ _ _ c1files] = c1params] <- #1truncated
on-same-line <- (= (car c1truncatepos) (car (cursorpos c1mainfile))))
(cursorpos (car c1truncatepos) (cdr c1truncatepos) c1mainfile)
(cursorpos 'l c1mainfile)
(if on-same-line (terpri c1files) el (terpri c1mainfile))
(over i <- c1cp by (1- i) until (zerop i) (tyo 32. c1mainfile))
(#1printer c1code
;this terrible cludge is in here to force c1obj into a register so that the
;call on MUNKAM will compile correctly!!!!!!
((lambda (foo) (munkam (+ foo 0))) c1obj)
c1params)
(if (not on-same-line) (terpri #1files))))
'||)
;________________________________________________________________________________
;this is a new endpage function which must be used if #continue is used because
;for some reason the system endpagefn will not do mores during the printout initiated by
;#continue.
(deffn #1endpagefn [tty]
(nointerrupt nil) (cursorpos 'z tty) (cursorpos 'l tty)
(princ '|##more##| tty)
(let ((echofiles nil)) (tyi))
(cursorpos 'z tty) (cursorpos 'l tty) (cursorpos 'top tty) (cursorpos 'l tty))
;this is the main entry function into the internals of the printer.
;it checks to see if the printer is being reenterd and if so rebinds all of the critical
;globals so that the old invocation will be protected. then it sets up the initial
;values of all of the globals and fires up the format functions.
(deffn #1printer [code obj inits]
;if reentering printer rebind everything and recurse.
(if #1nowprinting
(let (#1nowprinting #1obj #1flag #1length #1supstack #1indstack #1parents
#1size #1supsize #1rsize #1prinlevel #1prinlength #1prinendline
#1prinstartline #1cp #1linelen #1maxindentlen #1cline #1freelen
#1pending #1tabsize #1taboffset #1inptr #1pp #1supptr #1indptr #1prinmode
#1checkrecursion #1mainfile #1files #1atstart? #1wentup?
#1printing? #1fcode #1bcode #1bcodestack #1open-del #1close-del #1level
#1rindex #1princ-atoms #1print-like #1exploding #1explode-result)
(#1printer code obj inits))
;decode arguments and set up format control variables.
el (begin (#1nowprinting <- t)
(<- #1princ-atoms (not (zerop (boole 1. 1. code)))
#1print-like (not (zerop (boole 1. 2. code)))
#1exploding (not (zerop (boole 1. 8. code)))
#1checkrecursion #checkrecursion)
(if (zerop (boole 1. 4. code))
(<- #1prinlevel (or prinlevel 64000.)
#1prinlength (or prinlength 64000.)
#1prinendline (or prinendline 64000.)
#1prinstartline (or prinstartline 0.)
#1prinmode prinmode)
el (<- #1prinlevel 64000. #1prinlength 64000.
#1prinendline 64000. #1prinstartline 0.
#1prinmode nil)
(match inits
[_ (if (numberp _) (<- #1prinlevel _) el (null _)) :!_
_ (if (numberp _) (<- #1prinlength _) el (null _)) :!_
_ (if (numberp _) (<- #1prinendline _) el (null _)) :!_
_ (if (numberp _) (<- #1prinstartline _) el (null _)) :!_
_ (or (memq _ '(grind block tblock miser crush)) (null _)
(and (not (atom _)) (not (atom (cdr _))) (not (atom (cadr _)))))
= #1prinmode :!_
! inits]))
(<- #1prinmode (if (eq #1prinmode 'grind) nil
ef (eq #1prinmode 'crush) #1crush-template
ef (eq #1prinmode 'tblock) #1tblock-template
ef (eq #1prinmode 'block) #1block-template
ef (eq #1prinmode 'miser) #1miser-template
el #1prinmode)
#1files (if (or (not (atom (car inits))) (null (car inits))) (car inits)
el inits))
;having decoded the args, do the work.
(if (and (not #1exploding) #1print-like (not (> #1prinstartline 0)))
(terpri #1files))
(if (and (atom obj) (null #1format-dispatch) (null #1format-atom) (not #1exploding))
(if #1princ-atoms (princ obj #1files) ef (not (eq obj '||)) (prin1 obj #1files))
el (#1format-init)
(if (null (errset
(if (catch (call #1format-dispatch #1prinmode obj) #1printabort)
(if (not #1exploding)
(<- #1truncated [(cursorpos #1mainfile) #1cp #1mainfile
(boole 7. code 4.) (maknum obj)
[#1prinlevel #1prinlength nil #1cline
#1prinmode #1files]])
(if (and #1printing? (plusp #1freelen))
(princ '| ---| #1files))))))
(if (null (errset (let (prin1)
(print '|error while #PRINTing:|)
(print obj))))
(let (prin1)
(print '|error while PRINTing MUNKAM of |)
(princ (maknum obj))))))
(if (and (not #1exploding) #1print-like (null #1truncated) #1printing?)
(tyo 32. #1files))
(if #1exploding
(prog2 nil (nreverse #1explode-result) (<- #1explode-result nil))
el t))))
(deffn #1format-init []
(if (null #1size)
(<- #1obj (array nil nil 100.)
#1flag (array nil fixnum 100.)
#1length (array nil fixnum 100.)
#1supstack (array nil fixnum 50.)
#1bcodestack (array nil fixnum 50.)
#1indstack (array nil fixnum 50.)
#1parents (array nil nil 50.)
#1size 100.
#1supsize 50.
#1rsize 50.))
(<- #1mainfile (if #1files (car #1files)
ef (and ^r ^w (car outfiles))
el tyo)
#1cp (charpos #1mainfile)
#1linelen (- (linel #1mainfile) 5)
#1maxindentlen (+ #1cp (* 4 (// (- #1linelen #1cp) 5)))
#1cline 0
#1atstart? t
#1freelen (- #1linelen #1cp)
#1pending 0
#1wentup? nil
#1printing? (not (> #1prinstartline 0))
#1tabsize 1
#1taboffset 0
#1inptr -1
#1pp 0
#1supptr 0
(#1supstack 0) 0
#1indptr 0
(#1indstack 0) #1cp
#1open-del nil
#1close-del nil
#1fcode 'never
#1bcode 0
#1level #1prinlevel
#1rindex 0
#1explode-result nil))
(deffn #1format-dispatch [template item]
(if (hunkp item)
(call #1format-hunk (if template el #11level-block-template) item)
ef (eq (typep item) 'list)
(if template (call #1format-list template item)
el (begin (head <- (car item)
symbol? <- (eq (typep head) 'symbol)
grind-fn <- (if symbol? (get head '#grind-fn))
template <- (if symbol?
(if (get head '#grind-template)
ef (getl head #fn-grind-properties) #1fn-template
el #1default-symbol-car-grind-template)
ef (and (eq (typep head) 'list)
(eq (car head) 'lambda))
#1apply-template
el #1default-non-symbol-car-grind-template))
(if grind-fn (funcall grind-fn template item)
el (call #1format-list template item))))
el (if #1format-atom (funcall #1format-atom template item)
el (#1enter-obj item (if #1princ-atoms 'princ el 'prin1) nil)))
nil)
;________________________________________________________________________________
;this does recursion checking. it looks in the array #1parents to see if the
;item has already been encountered. if so, an atom of the form ^# is consed
;up to stand in its place. If not it is put in the array #1parents, and
;#1rindex is incremented. it is up to the format functions which call
;#1rcheck to see that the value of rindex is decremented correctly.
(deffn #1rcheck [item]
;if the item is an atom, or if we are not checking then return quick
(if (or (atom item) (not #1checkrecursion)) item
;if the array is not big enough to add this item extend the array
el (if (not (< #1rindex #1rsize))
(<- #1rsize (+ #1rindex 25.))
(*rearray #1parents (car (arraydims #1parents)) #1rsize))
;search #1parents for item if you don't find it add it at the end
(over i <- 0 by (1+ i) until nil
(if (= i #1rindex)
(<- (#1parents i) item)
(<- #1rindex (1+ #1rindex))
(return item))
;if you do find it cons up atom to return
(if (eq item (#1parents i))
(return (implode (append '(/^) (exploden (- #1rindex i)))))))))
(deffn #1format-list [[icode ! temp] list]
(let ((orindex #1rindex) (olevel #1level)
(close-del #1close-del) (open-del #1open-del))
(<- #1open-del nil #1close-del nil)
(if (zerop #1level) (#1enter-obj '# 'princ nil)
ef (atom (<- list (#1rcheck list))) (#1enter-obj list 'princ nil)
el (<- #1level (1- #1level))
(if (null icode)
(if (null open-del) (<- icode 1)
el (<- icode (flatc open-del)))
(if (atom (car list))
(if #1princ-atoms (<- icode (+ icode 1 (flatc (car list))))
el (<- icode (+ icode 1 (flatsize (car list)))))))
(#1enter-obj icode nil 'start)
(#1enter-format&obj 'never 0 (or open-del '|(|) 'princ nil)
(over i <- (if (zerop #1level) 2 el #1prinlength) by (1- i) until nil
over [head ! rest] <- list by rest until nil
over [[fcode ! subtemp] ! rtemp] <- temp by rtemp until nil
(if (or (minusp i) (and (zerop i) (or rest (not (atom head)))))
(#1enter-format&obj fcode 0 '|...| 'princ nil)
(exit))
(#1enter-format fcode (if (null rest) 0 el 1))
(call #1format-dispatch subtemp head)
(if (null rest) (exit))
(if (not (eq (typep (<- rest (#1rcheck rest))) 'list))
(#1enter-format&obj (caar rtemp) 1 '/. 'princ nil)
(#1enter-format 'never 0)
(call #1format-dispatch (cdar rtemp) rest)
(exit)))
(#1enter-format&obj 'never 0 (or close-del '|)|) 'princ 'end)
(<- #1rindex orindex #1level olevel))))
(defun #1format-lsubr nargs
(begin ([icode ! temp] <- (arg 1) olevel <- #1level
close-del <- #1close-del open-del <- #1open-del)
(<- #1open-del nil #1close-del nil)
(if (zerop #1level) (#1enter-obj '# 'princ nil)
el (<- #1level (1- #1level))
(if (null icode)
(if (null open-del) (<- icode 1)
el (<- icode (flatc open-del)))
(if (atom (arg 2))
(if #1princ-atoms (<- icode (+ icode 1 (flatc (arg 2))))
el (<- icode (+ icode 1 (flatsize (arg 2)))))))
(#1enter-obj icode nil 'start)
(#1enter-format&obj 'never 0 (or open-del '|(|) 'princ nil)
(over i <- (if (zerop #1level) 2 el #1prinlength) by (1- i) until nil
over J <- 2 by (1+ j) until (> j nargs) (arg j) -> head
over [[fcode ! subtemp] ! rtemp] <- temp by rtemp until nil
(if (or (minusp i) (and (zerop i) (or (< j nargs) (not (atom head)))))
(#1enter-format&obj fcode 0 '|...| 'princ nil)
(exit))
(#1enter-format fcode (if (= j nargs) 0 el 1))
(call #1format-dispatch subtemp head))
(#1enter-format&obj 'never 0 (or close-del '|)|) 'princ 'end)
(<- #1level olevel))))
;________________________________________________________________________________
(deffn #1format-hunk [[icode ! temp] hunk]
(begin (orindex <- #1rindex olevel <- #1level
close-del <- #1close-del open-del <- #1open-del
end <- (1- (hunksize hunk)))
(<- #1open-del nil #1close-del nil)
(if (zerop #1level) (#1enter-obj '# 'princ nil)
ef (atom (<- hunk (#1rcheck hunk))) (#1enter-obj hunk 'princ nil)
el (<- #1level (1- #1level))
(if (null icode)
(if (null open-del) (<- icode 1)
el (<- icode (flatc open-del)))
(if (atom (cxr 1 hunk))
(if #1princ-atoms (<- icode (+ icode 1 (flatc (cxr 1 hunk))))
el (<- icode (+ icode 1 (flatsize (cxr 1 hunk)))))))
(#1enter-obj icode nil 'start)
(#1enter-format&obj 'never 0 (or open-del '|{|) 'princ nil)
(over i <- (if (zerop #1level) 2 el #1prinlength) by (1- i) until nil
over j <- 1 by (1+ j) until (> j end) (cxr j hunk) -> head
over [[fcode ! subtemp] ! rtemp] <- temp by rtemp until nil
(<- temp rtemp)
(if (or (minusp i) (and (zerop i) (or (< j end) (not (atom head)))))
(#1enter-format&obj fcode 0 '|...| 'princ nil)
(exit))
(#1enter-format fcode 1)
(call #1format-dispatch subtemp head))
(#1enter-format (caar temp) 0)
(call #1format-dispatch (cdar temp) (cxr 0 hunk))
(#1enter-format&obj 'never 0 (or close-del '|}|) 'princ 'end)
(<- #1rindex orindex #1level olevel))))
;this section contains some special grind-fns. A grind-fn must be written when
;the template format is not powerfull enough to allow you to do what you want.
;this macro constructs grind functions which do read macro inversion of macros
;like quote (which expect that the relavent data is in the CADR), does inversion
;where the CDR is the data, and you are specifying both a new open and close delimeter.
;#make-inver-quote-fn2 makes inverts for macros like "`" which put the relavent data in
;the CDR. It sets up a sublist with the specified delimeters
;note that #1format-list bombs out if passed an atomic item, so this checks
;to see if the cdr of the item is atomic, and if so does not do the inversion.
;in order to improve readability, it also refuses to invert a list if it
;has only an open delimiter, and more than one element in the rest of the list.
(deffn #make-invert-quote-fn macro keep displace check
[_ atom open-del close-del :!_]
(if close-del
`(defun (,atom #grind-fn) (temp item)
(cond ((cdr item)
(setq #1open-del ',open-del #1close-del ',close-del)
(cond (#1format-list (funcall #1format-list temp (cdr item)))
((#1format-list temp (cdr item)))))
((cond (#1format-list (funcall #1format-list temp (cdr item)))
((#1format-list temp item))))))
el `(defun (,atom #grind-fn) (temp item)
(cond ((and (cdr item) (null (cddr item)))
(setq #1open-del ',open-del #1close-del '|| #1level (1+ #1level))
(cond (#1format-list (funcall #1format-list temp (cdr item)))
((#1format-list temp (cdr item))))
(setq #1level (1- #1level)))
((cond (#1format-list (funcall #1format-list temp (cdr item)))
((#1format-list temp item))))))))
;this causes (quote ...) to print as '...
(#make-invert-quote-fn quote /')
;________________________________________________________________________________
;this function works very similar to the above except it expects the goodies to be in the cdr
;and just prints them as a list if they are a list.
(deffn #make-invert-quote-fn2 macro keep displace check [_ internal-atom external-atom]
`(defun (,internal-atom #grind-fn) (temp item)
(#1enter-obj 0 nil 'start)
(#1enter-format&obj 'never 0 ',external-atom 'princ nil)
(#1enter-format 'never 0)
(cond (#1format-dispatch (funcall #1format-dispatch nil (cdr item)))
((#1format-dispatch nil (cdr item))))
(#1enter-obj '|| 'princ 'end)))
;these standard definitions make the `macro print nicely.
(#make-invert-quote-fn2 |`-expander/|| |`|)
(#make-invert-quote-fn2 |`,/|| |,|)
(#make-invert-quote-fn2 |`,@/|| |,@|)
(#make-invert-quote-fn2 |`,./|| |,.|)
;this makes defun print out right by checking whether it is of the one or two
;keyword form.
(deffn defun #grind-fn [temp item]
(<- temp (if (and (match item [_ _ _ ! _])
(or (memq (2nd item) '(expr fexpr macro))
(memq (3rd item) '(expr fexpr macro))))
#1defun2-template
el #1defun1-template))
(call #1format-list temp item))
;this makes the #printer obay the grind-macroexpanded flag from the
;file DEFMAX so that macro expansions created with
;macro-expansion-use=macroexpanded print pretty.
(defun (macroexpanded #grind-fn) (temp item)
(setq item (cond (grind-macroexpanded (cadddr (cdr item)))
(t (cadddr item))))
(setq #1level (1+ #1level))
(cond (#1format-dispatch (funcall #1format-dispatch temp item))
((#1format-dispatch temp item)))
(setq #1level (1- #1level)))
;this takes care of making the tags come out right in a prog or do. it looks
;complex but really it is exactly the same as #1format-list with a piece added in
;the middle that works with the tags. it works even if there are two or more
;tags in a row.
(deffn prog #grind-fn [unused-template list]
;if list is short and has no tags then print it like a list.
;otherwise we force things to be on separate lines even if there are no tags.
(if (over (cddr list) until (atom _)
over i <- 0 by (1+ i) until nil
fastand (if (> i 10) (return nil))
(not (atom _)))
(call #1format-list #1fn-template list)
el (begin (orindex <- #1rindex olevel <- #1level
default-bcode bcode
any-labs-yet? <- nil)
(if #1princ-atoms (<- default-bcode (1+ (flatc (car list))))
el (<- default-bcode (1+ (flatsize (car list)))))
(<- bcode default-bcode)
(if (zerop #1level) (#1enter-obj '# 'princ nil)
ef (atom (<- list (#1rcheck list))) (#1enter-obj list 'princ nil)
el (<- #1level (1- #1level))
(#1enter-obj 1 nil 'start)
(#1enter-format&obj 'never 0 '|(| 'princ nil)
(over i <- (if (zerop #1level) 2 el #1prinlength) by (1- i) until nil
over [head ! rest] <- list by rest until nil
over k <- 1 by (1- k) until nil
(if (or (minusp i) (and (zerop i) (or rest (not (atom head)))))
(#1enter-format&obj 'never 0 '|...| 'princ nil)
(exit))
;this is the new part which figures the undenting of the tags.
(if (minusp k)
(if (and (atom head) head)
(if #1princ-atoms
(<- bcode (- bcode 1 (flatc head)))
el (<- bcode (- bcode 1 (flatsize head))))
(#1enter-format&obj
(if any-labs-yet? 'never el 'always) 1
head (if #1princ-atoms 'princ el 'prin1) nil)
(<- any-labs-yet? t)
el (if (not any-labs-yet?)
(#1enter-format&obj 'always default-bcode '|| nil nil)
el (#1enter-format&obj 'never (max 0 bcode) '|| nil nil)
(<- bcode default-bcode any-labs-yet? nil))
(#1enter-format 'never (if (null rest) 0 el 1))
(call #1format-dispatch nil head))
el (#1enter-format 'never (if (null rest) 0 el 1))
(call #1format-dispatch #11level-block-template head))
;back to normal stuff from #1format-list
(if (null rest) (exit))
(if (not (eq (typep (<- rest (#1rcheck rest))) 'list))
(#1enter-format&obj 'never 1 '/. 'princ nil)
(#1enter-format 'never 0)
(call #1format-dispatch nil rest)
(exit)))
(#1enter-format&obj 'never 0 '|)| 'princ 'end)
(<- #1rindex orindex #1level olevel)))))
;do can be handled just like prog.
(putprop 'do (get 'prog '#grind-fn) '#grind-fn)
;#1enter makes things easier for the format functions by maintaining the
;consistency of the intermediate structure. In particular as sublists grow,
;it keeps the length, inner-always and complete fields accurate. in order to
;do this, it needs to know where the the superiors of the current element are.
;this is the function of #1supstack. it contains the offsets to the superiors.
;if the end of the arrays are reached, then it shifts things over. (this looks
;slow compared with using a queue rapping around in the arrays, but it saves
;enough overhead in other places that it wins in the long run. #1supstack
;contains offsets so that nothing special has to be done when things are
;shifted over.) (note that the arrays are expanded if they need to be.)
;special checks are made so the #1enter never bothers to update an elemetn
;which #1printout has already passed over. (this also avoids referenceing
;outside the arrays.) the zero position of #1supstack is left unused in order
;to solve a lot of fencepost problems. it gets written in now and then though
;it logically shouldn't.
(deffn #1enter-obj [obj pcode lcode]
(begin (flag <- (flags (if (eq pcode 'prin1) (flags 'prin1)
ef (eq pcode 'princ) (flags 'princ)
el 0)
(if (eq #1fcode 'never) (flags 'never)
ef (eq #1fcode 'normal) (flags 'normal)
ef (eq #1fcode 'tblock) (flags 'tblock)
ef (eq #1fcode 'block) (flags 'block)
el;(eq #1fcode 'always)
(flags 'always))
(if (eq lcode 'start) (flags 'list-start)
ef (eq lcode 'end)
(flags 'list-end 'complete (#1bcodestack #1supptr))
el;(eq lcode nil)
(flags 'complete #1bcode)))
length <- (if (list-start? flag) 0
ef (prin1? flag) (+ (bcode flag) (flatsize obj))
ef (princ? flag) (+ (bcode flag) (flatc obj))
el (bcode flag)))
(if #1exploding
(if (princ? flag)
(<- #1explode-result (nreconc (explodec obj) #1explode-result))
ef (prin1? flag)
(<- #1explode-result (nreconc (explode obj) #1explode-result)))
(over i <- (bcode flag) by (1- i) until (not (plusp i))
(pushonto #1explode-result '| |))
(if (list-start? flag)
(<- #1supptr (1+ #1supptr)
(#1bcodestack #1supptr) #1bcode)
ef (list-end? flag)
(<- #1supptr (1- #1supptr)))
;otherwise go to next queue element and queue the stuff up.
el (<- #1inptr (1+ #1inptr)
(#1supstack #1supptr) (1+ (#1supstack #1supptr)))
;check if we have gone passed the end of the queue, if we have shift things over, or
;(if we must) extend the size of the arrays.
(if (not (< #1inptr #1size))
(if (< #1pp 10.)
(<- #1size (+ #1size 10.))
(*rearray #1obj (car (arraydims #1obj)) #1size)
(*rearray #1flag (car (arraydims #1flag)) #1size)
(*rearray #1length (car (arraydims #1length)) #1size)
el (over j <- #1pp by (1+ j) until (= j #1size)
over i <- 0 by (1+ i) until nil
(<- (#1obj i) (#1obj j)
(#1flag i) (#1flag j)
(#1length i) (#1length j)))
(<- #1inptr (- #1inptr #1pp)
#1pp 0)))
;fill in the slots in the new queue element.
(<- (#1obj #1inptr) obj
(#1flag #1inptr) flag
(#1length #1inptr) length)
;update the lengths of the superiors of the new queue element.
(over i <- #1supptr by (1- i) until (zerop i)
over j <- (- #1inptr (#1supstack i)) by (- j (#1supstack i)) until (< j #1pp)
(<- (#1length j) (+ length (#1length j))))
;if this queue element has the always? bit on, put the inner-always bit on in its superiors
(if (always? flag)
(over i <- #1supptr by (1- i) until (zerop i)
over j <- (- #1inptr (#1supstack i)) by (- j (#1supstack i)) until (< j #1pp)
(<- (#1flag j) (flags (#1flag j) 'inner-always))))
;if this queue element is the start of a list push it onto the supstack. (extend if needed)
(if (list-start? flag)
(<- #1supptr (1+ #1supptr))
(if (not (< #1supptr #1supsize))
(<- #1supsize (+ #1supsize 10.))
(*rearray #1supstack (car (arraydims #1supstack)) #1supsize)
(*rearray #1indstack (car (arraydims #1indstack)) #1supsize)
(*rearray #1bcodestack (car (arraydims #1bcodestack)) #1supsize))
(<- (#1supstack #1supptr) 0
(#1bcodestack #1supptr) #1bcode)
;if this element is the end of a list mark the superior complete and pop it off the supstack.
ef (list-end? flag)
(let ((i (- #1inptr (#1supstack #1supptr))))
(if (not (> #1pp i))
(<- (#1flag i) (flags (#1flag i) 'complete))))
(<- #1supptr (1- #1supptr)
(#1supstack #1supptr) (+ (#1supstack #1supptr) (#1supstack (1+ #1supptr)))))
;call #1printout to see if anything can get printed out.
(#1printout)))
nil)
;this is the function that actually decides how things get printed out. it is
;essentially an interpreter for the intermediate structure looked at as a
;program. it implements all of the meanings of the codes. (comments near the
;beginning discuss the semantics of the various flags.) #1enter puts enough
;information at each node, that #1printout can make almost all of its
;decisions based solely on the information at one node and general information
;about where it is in printing. (tblocking is the only major exception, in
;that case it looks at a bunch of nodes in order to figure out what the tab
;size should be.)
(deffn #1printout []
;if there is no more intermediate structure exit
(loop (flag)
(if (> #1pp #1inptr) (exit))
(<- flag (#1flag #1pp))
;if it the next thing is ready to print, and we may have to tab before it, and
;we don't yet know the tabsize, find it out.
(if (and (tblock? flag) (complete? flag) (= #1tabsize 1))
(begin (n <- (max 2 (#1length #1pp))
i <- 0
max <- (over j <- #1pp by (1+ j) until (> j #1inptr)
(#1flag j) -> flag
return n
(if (= i 0) (<- n (max n (#1length j))))
(if (list-start? flag) (<- i (1+ i))
ef (list-end? flag) (<- i (1- i))))
space <- (- #1linelen (#1indstack #1indptr)))
(<- max (min space (+ max (// max 5)))
#1tabsize (// space (// space max))
#1taboffset (- (\ space #1tabsize) #1tabsize))))
;if we are not already at the start of a line see if we have to put a crlf
;before the next thing.
(if (not #1atstart?)
;if we have to tab before the next thing, then make sure we are in the right column
(if (and (tblock? flag) (complete? flag))
(let ((j (\ (- #1freelen #1taboffset) #1tabsize)))
(<- #1pending (+ #1pending j)
#1freelen (- #1freelen j))))
;check if the code implies doing a terpri
(if (or (always? flag)
(normal? flag)
(and (or (block? flag) (tblock? flag))
(or #1wentup? (inner-always? flag)
(and (> (#1length #1pp) #1freelen)
(< #1freelen (- #1linelen (#1indstack #1indptr))))))
(and (never? flag) (not (list-start? flag))
(> (#1length #1pp) (+ 4 #1freelen))))
;we do need a new line set it up
(<- #1atstart? t
#1wentup? nil
#1cline (1+ #1cline)
#1pending (#1indstack #1indptr)
#1freelen (- #1linelen #1pending))
;check if we have exceeded prinendline if so stop printing
(if (> #1cline #1prinendline)
(throw '|#1prinendline exceeded| #1printabort))
;do the terpri and set up for the correct indentation
(if #1printing? (terpri #1files)
ef (<- #1printing? (not (> #1prinstartline #1cline)))
(<- #1pending (- #1pending #1cp)))))
;if the current thing won't go on one line (because it is too long or has an
;inner-always) then go down into it calculating new indentation level
(if (and (list-start? flag) (or (inner-always? flag) (> (#1length #1pp) #1freelen)))
(<- #1indptr (1+ #1indptr)
(#1indstack #1indptr)
(let ((i (max #1cp (+ (#1obj #1pp) (- #1linelen #1freelen)))))
(if (> i #1maxindentlen) (+ #1cp
(// (- #1linelen #1cp) 5)
(- i #1maxindentlen))
el i))
#1pp (1+ #1pp)
#1tabsize 1)
;otherwise if this item is completed then it will fit on one line and we go
;ahead and print it out. (we count delemiters to know when we are done)
ef (complete? flag)
(<- #1freelen (- #1freelen (#1length #1pp))
#1atstart? nil)
(loop (i <- 0)
(if (list-start? flag) (<- i (1+ i))
el (if (list-end? flag) (<- i (1- i)))
(if #1printing?
(over j <- #1pending by (1- j) until (not (plusp j))
(tyo 32. #1files))
(if (princ? flag) (princ (#1obj #1pp) #1files)
ef (prin1? flag) (prin1 (#1obj #1pp) #1files)))
(<- #1pending (bcode flag)))
(<- #1pp (1+ #1pp))
(if (zerop i) (exit)
;if we have just gone over a list end, then pop up a level
ef (minusp i)
(<- #1indptr (1- #1indptr)
#1wentup? t
#1tabsize 64000.)
(exit))
(<- flag (#1flag #1pp)))
;if the current thing wasn't complete either, then we quit because we don't
;have enough information to decide what to do.
el (exit))))
;this is a macro expanded version if this file. the fasl version has actually been produced
;by compiling this version. it is included because it may be more readable to some, and
;in the hope that it will allow #print to be maintained after my macros and I have gone.
;all of the comments above apply to the expanded version.
(declare '(macro expanded version of code |two )) at end to match|
(DECLARE (FIXNUM I J K N LENGTH END RINDEX MAX DEFAULT-BCODE BCODE SPACE
LEVEL FLAGS)
(SPECIAL /#CHECKRECURSION PRINLEVEL
PRINLENGTH PRINMODE PRINENDLINE
PRINSTARTLINE ^R ^W
OUTFILES GRINDEF GRINDPROPERTIES
/#FN-GRIND-PROPERTIES
/#1DEFAULT-SYMBOL-CAR-GRIND-TEMPLATE
/#1DEFAULT-NON-SYMBOL-CAR-GRIND-TEMPLATE TYO
/#1FORMAT-DISPATCH /#1FORMAT-LIST /#1FORMAT-ATOM
/#1FORMAT-HUNK GRIND-MACROEXPANDED)
(SPECIAL /#1PRINLEVEL /#1PRINLENGTH
/#1PRINENDLINE /#1PRINSTARTLINE /#1CP
/#1LINELEN /#1MAXINDENTLEN /#1CLINE
/#1FREELEN /#1PENDING /#1TABSIZE
/#1TABOFFSET /#1INPTR /#1PP
/#1SUPPTR /#1INDPTR /#1SIZE
/#1SUPSIZE /#1RSIZE /#1PRINMODE
/#1CHECKRECURSION /#1MAINFILE /#1TRUNCATED
/#1FILES /#1ATSTART? /#1WENTUP?
/#1PRINTING? /#1OBJ /#1FLAG
/#1LENGTH /#1SUPSTACK /#1INDSTACK
/#1PARENTS /#1NOWPRINTING /#1FCODE
/#1BCODE /#1BCODESTACK /#1LEVEL
/#1RINDEX /#1OPEN-DEL /#1CLOSE-DEL
/#1PRINC-ATOMS /#1PRINT-LIKE /#1EXPLODING
/#1EXPLODE-RESULT)
(SPECIAL /#1MISER-TEMPLATE /#1BLOCK-TEMPLATE
/#1CRUSH-TEMPLATE /#1FN-TEMPLATE
/#11LEVEL-BLOCK-TEMPLATE /#1DEFUN1-TEMPLATE
/#1DEFUN2-TEMPLATE /#11LEVEL-TBLOCK-TEMPLATE
/#1APPLY-TEMPLATE /#11LEVEL-MISER-TEMPLATE
/#1TBLOCK-TEMPLATE)
(*LEXPR /#PRIN1 /#PRINT PRINL PRINL1))
(DEFUN /#MAKE-TEMPLATE (PATTERN) (/#MAKE-TEMPLATE1 PATTERN NIL NIL))
(DEFUN /#MAKE-TEMPLATE1 (PATTERN OLDBACKLIST NEWBACKLIST)
(COND ((ATOM PATTERN) PATTERN)
((MEMQ PATTERN OLDBACKLIST)
((LAMBDA (OVERVAROLD OLD OVERVARNEW NEW)
(PROGN (SETQ OVERVAROLD OLDBACKLIST)
(SETQ OVERVARNEW NEWBACKLIST))
(PROG NIL
U1_L (PROGN (SETQ OLD (CAR OVERVAROLD))
(SETQ NEW (CAR OVERVARNEW)))
(COND ((EQ OLD PATTERN) (RETURN NEW)))
(PROGN (SETQ OVERVAROLD (CDR OVERVAROLD))
(SETQ OVERVARNEW (CDR OVERVARNEW)))
(GO U1_L)))
NIL NIL NIL NIL))
((EQ (CAR PATTERN) '^)
((LAMBDA (OVERVARNEW NEW ICOUNT)
(PROGN (SETQ OVERVARNEW NEWBACKLIST)
(SETQ ICOUNT (1- (CDR PATTERN))))
(PROG NIL
U1_L (SETQ NEW (CAR OVERVARNEW))
(COND ((ZEROP ICOUNT) (RETURN NEW)))
(PROGN (SETQ OVERVARNEW (CDR OVERVARNEW))
(SETQ ICOUNT (1- ICOUNT)))
(GO U1_L)))
NIL NIL NIL))
(((LAMBDA (NEWCONS)
(SETQ OLDBACKLIST (CONS PATTERN OLDBACKLIST))
(SETQ NEWBACKLIST (CONS NEWCONS NEWBACKLIST))
(RPLACA NEWCONS
(/#MAKE-TEMPLATE1 (CAR PATTERN)
OLDBACKLIST
NEWBACKLIST))
(RPLACD NEWCONS
(/#MAKE-TEMPLATE1 (CDR PATTERN)
OLDBACKLIST
NEWBACKLIST))
NEWCONS)
(NCONS NIL)))))
(DEFUN /#1SET-UP-TEMPLATES NIL
(PROGN (SETQ /#1MISER-TEMPLATE
(/#MAKE-TEMPLATE '(1. (NEVER ^ . 3.)
(NORMAL ^ . 4.) ^
. 1.)))
(SETQ /#1CRUSH-TEMPLATE
(/#MAKE-TEMPLATE '(-900. (NEVER ^ . 3.) ^ . 1.)))
(SETQ /#1BLOCK-TEMPLATE
(/#MAKE-TEMPLATE '(1. (NEVER ^ . 3.)
(BLOCK ^ . 4.) ^
. 1.)))
(SETQ /#1TBLOCK-TEMPLATE
(/#MAKE-TEMPLATE '(1. (NEVER ^ . 3.)
(TBLOCK ^ . 4.) ^
. 1.)))
(SETQ /#1FN-TEMPLATE
(/#MAKE-TEMPLATE '(NIL (NEVER) (NEVER) (NORMAL) ^ . 1.)))
(SETQ /#11LEVEL-MISER-TEMPLATE
(/#MAKE-TEMPLATE '(1. (NEVER) (NORMAL) ^ . 1.)))
(SETQ /#11LEVEL-BLOCK-TEMPLATE
(/#MAKE-TEMPLATE '(1. (BLOCK) ^ . 1.)))
(SETQ /#11LEVEL-TBLOCK-TEMPLATE
(/#MAKE-TEMPLATE '(1. (TBLOCK) ^ . 1.)))
(SETQ /#1DEFAULT-SYMBOL-CAR-GRIND-TEMPLATE /#1FN-TEMPLATE)
(SETQ /#1DEFAULT-NON-SYMBOL-CAR-GRIND-TEMPLATE
/#11LEVEL-MISER-TEMPLATE)
(PUTPROP 'LAMBDA
(/#MAKE-TEMPLATE '(2.
(NEVER)
(NEVER 1. (BLOCK) ^ . 1.)
(NORMAL)
^
. 1.))
'/#GRIND-TEMPLATE)
(SETQ /#1APPLY-TEMPLATE
(/#MAKE-TEMPLATE '(1. (NEVER) (BLOCK) ^ . 1.)))
(PUTPROP 'SETQ
(/#MAKE-TEMPLATE '(NIL (NEVER) (NEVER)
(BLOCK) (ALWAYS) (BLOCK)
^ . 2.))
'/#GRIND-TEMPLATE)
(PUTPROP 'COND
(/#MAKE-TEMPLATE '(NIL
(NEVER)
(NEVER 1. (NEVER) (NORMAL) ^ . 1.)
(ALWAYS 1. (NEVER) (NORMAL) ^ . 1.)
^
. 1.))
'/#GRIND-TEMPLATE)
(SETQ /#1DEFUN1-TEMPLATE
(/#MAKE-TEMPLATE '(2. (NEVER) (NEVER)
(NEVER) (NORMAL) ^
. 1.)))
(SETQ /#1DEFUN2-TEMPLATE
(/#MAKE-TEMPLATE '(2. (NEVER) (NEVER) (NEVER)
(NEVER) (NORMAL) ^ . 1.)))))
(/#1SET-UP-TEMPLATES)
(DEFUN /#1SET-UP-GLOBALS NIL
(SETQ /#1TRUNCATED NIL)
((LAMBDA (|OVERVAR([ ATOM VAL)| VAL ATOM)
(SETQ |OVERVAR([ ATOM VAL)|
'((PRINLEVEL NIL)
(PRINLENGTH NIL)
(PRINMODE GRIND)
(PRINSTARTLINE NIL)
(PRINENDLINE NIL)
(/#CHECKRECURSION NIL)
(/#FN-GRIND-PROPERTIES (EXPR FEXPR
MACRO
SUBR
LSUBR
FSUBR
ARRAY
AUTOLOAD))
(GRINDPROPERTIES (EXPR FEXPR MACRO))
(GRINDEF NIL)
(/#1FORMAT-DISPATCH NIL)
(/#1FORMAT-LIST NIL)
(/#1FORMAT-HUNK NIL)
(/#1FORMAT-ATOM NIL)
(/#1NOWPRINTING NIL)
(/#1SIZE NIL)))
(PROG NIL
U1_L (COND ((NULL |OVERVAR([ ATOM VAL)|) (RETURN NIL)))
((LAMBDA (U1_ITEM)
(SETQ ATOM (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ VAL (CAR U1_ITEM)))
(CAR |OVERVAR([ ATOM VAL)|))
(COND ((NOT (BOUNDP ATOM)) (SET ATOM VAL)))
(SETQ |OVERVAR([ ATOM VAL)| (CDR |OVERVAR([ ATOM VAL)|))
(GO U1_L)))
NIL NIL NIL))
(/#1SET-UP-GLOBALS)
(DEFUN /#1SET-UP-PRINTER NIL
(SSTATUS TTYINT 19. '/#PRINTABORT)
(SSTATUS TTYINT 3. '/#CONTINUE)
(ENDPAGEFN TYO '/#1ENDPAGEFN)
(SETQ PRIN1 '/#PRIN1))
(DEFUN /#1REM-PRINTER NIL
(COND ((EQ (STATUS TTYINT 19.) '/#PRINTABORT) (SSTATUS TTYINT 19. NIL)))
(COND ((EQ (STATUS TTYINT 3.) '/#CONTINUE) (SSTATUS TTYINT 3. NIL)))
(COND ((EQ (ENDPAGEFN TYO) '/#1ENDPAGEFN)
(ENDPAGEFN TYO '+INTERNAL-TTY-ENDPAGEFN)))
(SETQ PRIN1 NIL)
((LAMBDA (OVERVAR_ _)
(SETQ OVERVAR_
'((/#1ENTER-FORMAT MACRO)
(/#1ENTER-FORMAT&OBJ MACRO)
(/#MAKE-TEMPLATE SUBR)
(/#MAKE-TEMPLATE1 SUBR)
(/#1SET-UP-TEMPLATES SUBR)
(/#1SET-UP-GLOBALS SUBR)
(/#1SET-UP-PRINTER SUBR)
(/#1REM-PRINTER SUBR)
(/#PRIN1 LSUBR)
(/#PRINC LSUBR)
(/#PRINT LSUBR)
(/#PRINL1 LSUBR)
(/#PRINLC LSUBR)
(/#PRINL LSUBR)
(/#EXPLODE SUBR)
(/#EXPLODEC SUBR)
(/#EXPLODEL LSUBR)
(GRINDEF FSUBR)
(/#1PRINTABORT SUBR)
(/#CONTINUE SUBR)
(/#1ENDPAGE-FN SUBR)
(/#1PRINTER SUBR)
(/#1FORMAT-INIT SUBR)
(/#1FORMAT-DISPATCH SUBR)
(/#1RCHECK SUBR)
(/#1FORMAT-LIST SUBR)
(/#1FORMAT-LSUBR LSUBR)
(/#1FORMAT-HUNK SUBR)
(/#MAKE-INVERT-QUOTE-FN MACRO)
(/#MAKE-INVERT-QUOTE-FN2 MACRO)
'/#GRIND-FN
(DEFUN /#GRIND-FN)
(PROG /#GRIND-FN)
(DO /#GRIND-FN)
NIL
(/#1SET-UP-MACROS SUBR)
(/#1ENTER-OBJ SUBR)
(/#1PRINTOUT SUBR)))
(PROG NIL
U1_L (COND ((NULL OVERVAR_) (RETURN NIL)))
(SETQ _ (CAR OVERVAR_))
(REMPROP (CAR _) (CDR _))
(SETQ OVERVAR_ (CDR OVERVAR_))
(GO U1_L)))
NIL NIL)
((LAMBDA (OVERVAR_ _)
(SETQ OVERVAR_
'(/#1OBJ /#1FLAG
/#1LENGTH
/#1SUPSTACK
/#1BCODESTACK
/#1INDSTACK
/#1PARENTS
/#1POBJ))
(PROG NIL
U1_L (COND ((NULL OVERVAR_) (RETURN NIL)))
(SETQ _ (CAR OVERVAR_))
(MAKUNBOUND _)
(SETQ OVERVAR_ (CDR OVERVAR_))
(GO U1_L)))
NIL NIL))
(DEFUN /#PRIN1 NARGS (/#1PRINTER 0. (ARG 1.) (LISTIFY (- 1. NARGS))))
(DEFUN /#PRINC NARGS (/#1PRINTER 1. (ARG 1.) (LISTIFY (- 1. NARGS))))
(DEFUN /#PRINT NARGS (/#1PRINTER 2. (ARG 1.) (LISTIFY (- 1. NARGS))))
(DEFUN PRINL1 NARGS (/#1PRINTER 4. (ARG 1.) (LISTIFY (- 1. NARGS))))
(DEFUN PRINLC NARGS (/#1PRINTER 5. (ARG 1.) (LISTIFY (- 1. NARGS))))
(DEFUN PRINL NARGS (/#1PRINTER 6. (ARG 1.) (LISTIFY (- 1. NARGS))))
(DEFUN /#EXPLODE (OBJ) (/#1PRINTER 8. OBJ NIL))
(DEFUN /#EXPLODEC (OBJ) (/#1PRINTER 9. OBJ NIL))
(DEFUN /#EXPLODEL NARGS (/#1PRINTER 14. (ARG 1.) (LISTIFY (- 1. NARGS))))
(DEFUN GRINDEF FEXPR (ARG)
((LAMBDA (ATOMS PROPS SELECTEDPROPS)
(PROGN ((LAMBDA (U1_ITEM)
(OR (AND (NOT (ATOM U1_ITEM))
(NOT (ATOM (CAR U1_ITEM)))
(PROGN (SETQ PROPS (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
T))
T)
(SETQ ATOMS U1_ITEM))
(COND (ARG (SETQ GRINDEF ARG))
(GRINDEF)))
(SETQ SELECTEDPROPS (APPEND PROPS GRINDPROPERTIES)))
((LAMBDA (OVERVARATOM ATOM TRACED)
(SETQ OVERVARATOM ATOMS)
(PROG NIL
U1_L (COND ((NULL OVERVARATOM) (RETURN NIL)))
(PROGN (SETQ ATOM (CAR OVERVARATOM))
(SETQ TRACED
(AND (STATUS FEATURE TRACE)
(MEMQ ATOM (TRACE)))))
((LAMBDA (REST PROP IND)
((LAMBDA (U1_ITEM)
(SETQ IND (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ PROP (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ REST U1_ITEM))
(PLIST ATOM))
(PROG NIL
U1_L (COND ((NULL IND) (RETURN NIL)))
(COND ((AND (COND ((AND TRACED
(MEMQ IND
'(EXPR FEXPR MACRO)))
(SETQ TRACED NIL)
(COND ((MEMQ IND
SELECTEDPROPS)
(TERPRI)
(PRINC '|;traced|)))
NIL)
(T))
(MEMQ IND SELECTEDPROPS))
(COND ((AND (NOT (ATOM PROP))
(EQ (CAR PROP) 'LAMBDA))
(PRINL (CONS 'DEFUN
(NCONC (COND ((EQ IND
'EXPR)
(LIST ATOM))
((MEMQ IND '(FEXPR MACRO)) (LIST ATOM IND))
((LIST (LIST ATOM IND))))
(CDR PROP)))
'GRIND))
((PRINL (LIST 'DEFPROP
ATOM
PROP
IND)
'GRIND)))))
((LAMBDA (U1_ITEM)
(SETQ IND (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ PROP (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ REST U1_ITEM))
REST)
(GO U1_L)))
NIL NIL NIL)
(SETQ OVERVARATOM (CDR OVERVARATOM))
(GO U1_L)))
NIL NIL NIL))
NIL NIL NIL)
'||)
(DEFUN /#PRINTABORT (UNUSED-F UNUSED-CH)
(NOINTERRUPT NIL)
(TYI TYI)
(COND (/#1NOWPRINTING (ERRSET (THROW '|aborted| /#1PRINTABORT)))))
(DECLARE ((LAMBDA (OBARRAY) (REMPROP (INTERN 'CURSORPOS) (INTERN 'ACS)))
SOBARRAY))
(DEFUN /#CONTINUE (UNUSED-F UNUSED-CH)
(NOINTERRUPT NIL)
(TYI TYI)
(COND (/#1TRUNCATED
((LAMBDA (C1PARAMS C1FILES C1OBJ C1CODE C1MAINFILE C1CP
C1TRUNCATEPOS ON-SAME-LINE)
(PROGN ((LAMBDA (U1_ITEM)
(SETQ C1TRUNCATEPOS (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ C1CP (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ C1MAINFILE (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ C1CODE (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ C1OBJ (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
((LAMBDA (U1_ITEM)
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ C1FILES (CAR U1_ITEM)))
(CAR U1_ITEM))
(SETQ C1PARAMS (CAR U1_ITEM)))
/#1TRUNCATED)
(SETQ ON-SAME-LINE
(= (CAR C1TRUNCATEPOS)
(CAR (CURSORPOS C1MAINFILE)))))
(CURSORPOS (CAR C1TRUNCATEPOS)
(CDR C1TRUNCATEPOS)
C1MAINFILE)
(CURSORPOS 'L C1MAINFILE)
(COND (ON-SAME-LINE (TERPRI C1FILES))
((TERPRI C1MAINFILE)))
((LAMBDA (I)
(SETQ I C1CP)
(PROG NIL
U1_L (COND ((ZEROP I) (RETURN NIL)))
(TYO 32. C1MAINFILE)
(SETQ I (1- I))
(GO U1_L)))
NIL)
(/#1PRINTER C1CODE
((LAMBDA (FOO) (MUNKAM (+ FOO 0.))) C1OBJ)
C1PARAMS)
(COND ((NOT ON-SAME-LINE) (TERPRI /#1FILES))))
NIL NIL NIL NIL NIL NIL NIL NIL)))
'||)
(DEFUN /#1ENDPAGEFN (TTY)
(NOINTERRUPT NIL)
(CURSORPOS 'Z TTY)
(CURSORPOS 'L TTY)
(PRINC '|##more##| TTY)
((LAMBDA (ECHOFILES) (TYI)) NIL)
(CURSORPOS 'Z TTY)
(CURSORPOS 'L TTY)
(CURSORPOS 'TOP TTY)
(CURSORPOS 'L TTY))
(DEFUN /#1PRINTER (CODE OBJ INITS)
(COND (/#1NOWPRINTING
((LAMBDA (/#1NOWPRINTING /#1OBJ /#1FLAG /#1LENGTH /#1SUPSTACK
/#1INDSTACK /#1PARENTS /#1SIZE /#1SUPSIZE /#1RSIZE
/#1PRINLEVEL /#1PRINLENGTH /#1PRINENDLINE
/#1PRINSTARTLINE /#1CP /#1LINELEN /#1MAXINDENTLEN
/#1CLINE /#1FREELEN /#1PENDING /#1TABSIZE
/#1TABOFFSET /#1INPTR /#1PP /#1SUPPTR /#1INDPTR
/#1PRINMODE /#1CHECKRECURSION /#1MAINFILE /#1FILES
/#1ATSTART? /#1WENTUP? /#1PRINTING? /#1FCODE /#1BCODE
/#1BCODESTACK /#1OPEN-DEL /#1CLOSE-DEL /#1LEVEL
/#1RINDEX /#1PRINC-ATOMS /#1PRINT-LIKE /#1EXPLODING
/#1EXPLODE-RESULT)
(/#1PRINTER CODE OBJ INITS))
NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))
(((LAMBDA (/#1NOWPRINTING)
(SETQ /#1NOWPRINTING T)
(PROGN (SETQ /#1PRINC-ATOMS (NOT (ZEROP (BOOLE 1. 1. CODE))))
(SETQ /#1PRINT-LIKE (NOT (ZEROP (BOOLE 1. 2. CODE))))
(SETQ /#1EXPLODING (NOT (ZEROP (BOOLE 1. 8. CODE))))
(SETQ /#1CHECKRECURSION /#CHECKRECURSION))
(COND ((ZEROP (BOOLE 1. 4. CODE))
(PROGN (SETQ /#1PRINLEVEL (OR PRINLEVEL 64000.))
(SETQ /#1PRINLENGTH (OR PRINLENGTH 64000.))
(SETQ /#1PRINENDLINE (OR PRINENDLINE 64000.))
(SETQ /#1PRINSTARTLINE (OR PRINSTARTLINE 0.))
(SETQ /#1PRINMODE PRINMODE)))
(T
(PROGN (SETQ /#1PRINLEVEL 64000.)
(SETQ /#1PRINLENGTH 64000.)
(SETQ /#1PRINENDLINE 64000.)
(SETQ /#1PRINSTARTLINE 0.)
(SETQ /#1PRINMODE NIL))
((LAMBDA (U1_ITEM)
(AND (OR (AND (NOT (ATOM U1_ITEM))
(COND ((NUMBERP (CAR U1_ITEM))
(SETQ /#1PRINLEVEL
(CAR U1_ITEM)))
((NULL (CAR U1_ITEM))))
(PROGN (SETQ U1_ITEM (CDR U1_ITEM))
T))
T)
(OR (AND (NOT (ATOM U1_ITEM))
(COND ((NUMBERP (CAR U1_ITEM))
(SETQ /#1PRINLENGTH
(CAR U1_ITEM)))
((NULL (CAR U1_ITEM))))
(PROGN (SETQ U1_ITEM (CDR U1_ITEM))
T))
T)
(OR (AND (NOT (ATOM U1_ITEM))
(COND ((NUMBERP (CAR U1_ITEM))
(SETQ /#1PRINENDLINE
(CAR U1_ITEM)))
((NULL (CAR U1_ITEM))))
(PROGN (SETQ U1_ITEM (CDR U1_ITEM))
T))
T)
(OR (AND (NOT (ATOM U1_ITEM))
(COND ((NUMBERP (CAR U1_ITEM))
(SETQ /#1PRINSTARTLINE
(CAR U1_ITEM)))
((NULL (CAR U1_ITEM))))
(PROGN (SETQ U1_ITEM (CDR U1_ITEM))
T))
T)
(OR (AND (NOT (ATOM U1_ITEM))
(OR (MEMQ (CAR U1_ITEM)
'(GRIND BLOCK
TBLOCK
MISER
CRUSH))
(NULL (CAR U1_ITEM))
(AND (NOT (ATOM (CAR U1_ITEM)))
(NOT (ATOM (CDR (CAR U1_ITEM)))
)
(NOT (ATOM (CADR (CAR U1_ITEM)))
)))
(PROGN (SETQ /#1PRINMODE
(CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
T))
T)
(PROGN (SETQ INITS U1_ITEM) T)))
INITS)))
(PROGN (SETQ /#1PRINMODE
(COND ((EQ /#1PRINMODE 'GRIND) NIL)
((EQ /#1PRINMODE 'CRUSH)
/#1CRUSH-TEMPLATE)
((EQ /#1PRINMODE 'TBLOCK)
/#1TBLOCK-TEMPLATE)
((EQ /#1PRINMODE 'BLOCK)
/#1BLOCK-TEMPLATE)
((EQ /#1PRINMODE 'MISER)
/#1MISER-TEMPLATE)
(/#1PRINMODE)))
(SETQ /#1FILES
(COND ((OR (NOT (ATOM (CAR INITS)))
(NULL (CAR INITS)))
(CAR INITS))
(INITS))))
(COND ((AND (NOT /#1EXPLODING)
/#1PRINT-LIKE
(NOT (> /#1PRINSTARTLINE 0.)))
(TERPRI /#1FILES)))
(COND ((AND (ATOM OBJ)
(NULL /#1FORMAT-DISPATCH)
(NULL /#1FORMAT-ATOM)
(NOT /#1EXPLODING))
(COND (/#1PRINC-ATOMS (PRINC OBJ /#1FILES))
((NOT (EQ OBJ '||)) (PRIN1 OBJ /#1FILES))))
(T
(/#1FORMAT-INIT)
(COND ((NULL (ERRSET (COND ((CATCH (COND (
/#1FORMAT-DISPATCH
(FUNCALL /#1FORMAT-DISPATCH /#1PRINMODE OBJ))
((/#1FORMAT-DISPATCH /#1PRINMODE OBJ)))
/#1PRINTABORT)
(COND ((NOT /#1EXPLODING)
(SETQ /#1TRUNCATED
(LIST (CURSORPOS /#1MAINFILE)
/#1CP
/#1MAINFILE
(BOOLE 7. CODE 4.)
(MAKNUM OBJ)
(LIST /#1PRINLEVEL
/#1PRINLENGTH
NIL
/#1CLINE
/#1PRINMODE
/#1FILES)))
(COND ((AND
/#1PRINTING?
(PLUSP /#1FREELEN))
(PRINC '| ---| /#1FILES)))))))))
(COND ((NULL (ERRSET ((LAMBDA (PRIN1)
(PRINT '
|error while #PRINTing:|)
(PRINT OBJ))
NIL)))
((LAMBDA (PRIN1)
(PRINT '|error while PRINTing MUNKAM of |
)
(PRINC (MAKNUM OBJ)))
NIL)))))))
(COND ((AND (NOT /#1EXPLODING)
/#1PRINT-LIKE
(NULL /#1TRUNCATED)
/#1PRINTING?)
(TYO 32. /#1FILES)))
(COND (/#1EXPLODING
(PROG2 NIL
(NREVERSE /#1EXPLODE-RESULT)
(SETQ /#1EXPLODE-RESULT NIL)))
(T)))
NIL))))
(DEFUN /#1FORMAT-INIT NIL
(COND ((NULL /#1SIZE)
(PROGN (SETQ /#1OBJ (ARRAY NIL NIL 100.))
(SETQ /#1FLAG (ARRAY NIL FIXNUM 100.))
(SETQ /#1LENGTH (ARRAY NIL FIXNUM 100.))
(SETQ /#1SUPSTACK (ARRAY NIL FIXNUM 50.))
(SETQ /#1BCODESTACK (ARRAY NIL FIXNUM 50.))
(SETQ /#1INDSTACK (ARRAY NIL FIXNUM 50.))
(SETQ /#1PARENTS (ARRAY NIL NIL 50.))
(SETQ /#1SIZE 100.)
(SETQ /#1SUPSIZE 50.)
(SETQ /#1RSIZE 50.))))
(PROGN (SETQ /#1MAINFILE
(COND (/#1FILES (CAR /#1FILES))
((AND ^R ^W (CAR OUTFILES)))
(TYO)))
(SETQ /#1CP (CHARPOS /#1MAINFILE))
(SETQ /#1LINELEN (- (LINEL /#1MAINFILE) 5.))
(SETQ /#1MAXINDENTLEN
(+ /#1CP (* 4. (// (- /#1LINELEN /#1CP) 5.))))
(SETQ /#1CLINE 0.)
(SETQ /#1ATSTART? T)
(SETQ /#1FREELEN (- /#1LINELEN /#1CP))
(SETQ /#1PENDING 0.)
(SETQ /#1WENTUP? NIL)
(SETQ /#1PRINTING? (NOT (> /#1PRINSTARTLINE 0.)))
(SETQ /#1TABSIZE 1.)
(SETQ /#1TABOFFSET 0.)
(SETQ /#1INPTR -1.)
(SETQ /#1PP 0.)
(SETQ /#1SUPPTR 0.)
(STORE (ARRAYCALL FIXNUM /#1SUPSTACK 0.) 0.)
(SETQ /#1INDPTR 0.)
(STORE (ARRAYCALL FIXNUM /#1INDSTACK 0.) /#1CP)
(SETQ /#1OPEN-DEL NIL)
(SETQ /#1CLOSE-DEL NIL)
(SETQ /#1FCODE 'NEVER)
(SETQ /#1BCODE 0.)
(SETQ /#1LEVEL /#1PRINLEVEL)
(SETQ /#1RINDEX 0.)
(SETQ /#1EXPLODE-RESULT NIL)))
(DEFUN /#1FORMAT-DISPATCH (TEMPLATE ITEM)
(COND ((HUNKP ITEM)
(COND (/#1FORMAT-HUNK
(FUNCALL /#1FORMAT-HUNK
(COND (TEMPLATE)
(/#11LEVEL-BLOCK-TEMPLATE))
ITEM))
((/#1FORMAT-HUNK (COND (TEMPLATE)
(/#11LEVEL-BLOCK-TEMPLATE))
ITEM))))
((EQ (TYPEP ITEM) 'LIST)
(COND (TEMPLATE
(COND (/#1FORMAT-LIST
(FUNCALL /#1FORMAT-LIST TEMPLATE ITEM))
((/#1FORMAT-LIST TEMPLATE ITEM))))
(((LAMBDA (HEAD SYMBOL? GRIND-FN TEMPLATE)
(PROGN (SETQ HEAD (CAR ITEM))
(SETQ SYMBOL? (EQ (TYPEP HEAD) 'SYMBOL))
(SETQ GRIND-FN
(COND (SYMBOL? (GET HEAD '/#GRIND-FN))))
(SETQ TEMPLATE
(COND (SYMBOL?
(COND ((GET HEAD
'/#GRIND-TEMPLATE))
((GETL HEAD
/#FN-GRIND-PROPERTIES)
/#1FN-TEMPLATE)
(
/#1DEFAULT-SYMBOL-CAR-GRIND-TEMPLATE
)))
((AND (EQ (TYPEP HEAD) 'LIST)
(EQ (CAR HEAD) 'LAMBDA))
/#1APPLY-TEMPLATE)
(
/#1DEFAULT-NON-SYMBOL-CAR-GRIND-TEMPLATE
))))
(COND (GRIND-FN (FUNCALL GRIND-FN TEMPLATE ITEM))
((COND (/#1FORMAT-LIST
(FUNCALL /#1FORMAT-LIST TEMPLATE ITEM))
((/#1FORMAT-LIST TEMPLATE ITEM))))))
NIL NIL NIL NIL))))
((COND (/#1FORMAT-ATOM (FUNCALL /#1FORMAT-ATOM TEMPLATE ITEM))
((/#1ENTER-OBJ ITEM
(COND (/#1PRINC-ATOMS 'PRINC)
('PRIN1))
NIL)))))
NIL)
(DEFUN /#1RCHECK (ITEM)
(COND ((OR (ATOM ITEM) (NOT /#1CHECKRECURSION)) ITEM)
(T
(COND ((NOT (< /#1RINDEX /#1RSIZE))
(SETQ /#1RSIZE (+ /#1RINDEX 25.))
(*REARRAY /#1PARENTS
(CAR (ARRAYDIMS /#1PARENTS))
/#1RSIZE)))
((LAMBDA (I)
(SETQ I 0.)
(PROG NIL
U1_L (PROGN (COND ((= I /#1RINDEX)
(STORE (ARRAYCALL NIL /#1PARENTS I)
ITEM)
(SETQ /#1RINDEX (1+ /#1RINDEX))
(RETURN ITEM)))
(COND ((EQ ITEM (ARRAYCALL NIL /#1PARENTS I))
(RETURN (IMPLODE (APPEND '(^)
(EXPLODEN (- /#1RINDEX I))))))))
(SETQ I (1+ I))
(GO U1_L)))
NIL))))
(DEFUN /#1FORMAT-LIST (|U1_ARG1.| LIST)
((LAMBDA (ICODE TEMP)
(COND ((NOT ((LAMBDA (U1_ITEM)
(AND (NOT (ATOM U1_ITEM))
(PROGN (SETQ ICODE (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ TEMP U1_ITEM)
T)))
|U1_ARG1.|))
(ERROR 'BAD-ARGS-TO-/#1FORMAT-LIST (LIST |U1_ARG1.| LIST))))
((LAMBDA (ORINDEX OLEVEL CLOSE-DEL OPEN-DEL)
(PROGN (SETQ /#1OPEN-DEL NIL) (SETQ /#1CLOSE-DEL NIL))
(COND ((ZEROP /#1LEVEL) (/#1ENTER-OBJ '/# 'PRINC NIL))
((ATOM (SETQ LIST (/#1RCHECK LIST)))
(/#1ENTER-OBJ LIST 'PRINC NIL))
(T
(SETQ /#1LEVEL (1- /#1LEVEL))
(COND ((NULL ICODE)
(COND ((NULL OPEN-DEL) (SETQ ICODE 1.))
((SETQ ICODE (FLATC OPEN-DEL))))
(COND ((ATOM (CAR LIST))
(COND (/#1PRINC-ATOMS
(SETQ ICODE
(+ ICODE 1. (FLATC (CAR LIST)))))
((SETQ ICODE
(+ ICODE
1.
(FLATSIZE (CAR LIST))))))))))
(/#1ENTER-OBJ ICODE NIL 'START)
(PROGN (SETQ /#1FCODE 'NEVER
/#1BCODE 0.)
(/#1ENTER-OBJ (OR OPEN-DEL '|(|) 'PRINC NIL))
((LAMBDA (I REST HEAD RTEMP SUBTEMP FCODE)
(PROGN (SETQ I
(COND ((ZEROP /#1LEVEL) 2.)
(/#1PRINLENGTH)))
((LAMBDA (U1_ITEM)
(SETQ HEAD (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ REST U1_ITEM))
LIST)
((LAMBDA (U1_ITEM)
((LAMBDA (U1_ITEM)
(SETQ FCODE (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ SUBTEMP U1_ITEM))
(CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ RTEMP U1_ITEM))
TEMP))
(PROG NIL
U1_L (PROGN (COND ((OR (MINUSP I)
(AND (ZEROP I)
(OR REST
(NOT (ATOM HEAD)))))
(PROGN (SETQ /#1FCODE FCODE
/#1BCODE 0.)
(/#1ENTER-OBJ '|...|
'PRINC
NIL))
(RETURN NIL)))
(SETQ /#1FCODE FCODE
/#1BCODE
(COND ((NULL REST) 0.)
(1.)))
(COND (/#1FORMAT-DISPATCH
(FUNCALL /#1FORMAT-DISPATCH
SUBTEMP
HEAD))
((/#1FORMAT-DISPATCH SUBTEMP HEAD)))
(COND ((NULL REST) (RETURN NIL)))
(COND ((NOT (EQ (TYPEP (SETQ REST
(/#1RCHECK REST)))
'LIST))
(PROGN (SETQ /#1FCODE (CAAR RTEMP)
/#1BCODE 1.)
(/#1ENTER-OBJ '|.|
'PRINC
NIL))
(SETQ /#1FCODE 'NEVER
/#1BCODE 0.)
(COND (/#1FORMAT-DISPATCH
(FUNCALL /#1FORMAT-DISPATCH
(CDAR RTEMP)
REST))
((/#1FORMAT-DISPATCH (CDAR RTEMP
)
REST)))
(RETURN NIL))))
(PROGN (SETQ I (1- I))
((LAMBDA (U1_ITEM)
(SETQ HEAD (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ REST U1_ITEM))
REST)
((LAMBDA (U1_ITEM)
((LAMBDA (U1_ITEM)
(SETQ FCODE (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ SUBTEMP U1_ITEM))
(CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ RTEMP U1_ITEM))
RTEMP))
(GO U1_L)))
NIL NIL NIL NIL NIL NIL)
(PROGN (SETQ /#1FCODE 'NEVER
/#1BCODE 0.)
(/#1ENTER-OBJ (OR CLOSE-DEL '|)|) 'PRINC 'END))
(PROGN (SETQ /#1RINDEX ORINDEX) (SETQ /#1LEVEL OLEVEL)))))
/#1RINDEX /#1LEVEL /#1CLOSE-DEL /#1OPEN-DEL))
NIL NIL))
(DEFUN /#1FORMAT-LSUBR NARGS
((LAMBDA (TEMP ICODE OLEVEL CLOSE-DEL OPEN-DEL)
(PROGN ((LAMBDA (U1_ITEM)
(SETQ ICODE (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ TEMP U1_ITEM))
(ARG 1.))
(SETQ OLEVEL /#1LEVEL)
(SETQ CLOSE-DEL /#1CLOSE-DEL)
(SETQ OPEN-DEL /#1OPEN-DEL))
(PROGN (SETQ /#1OPEN-DEL NIL) (SETQ /#1CLOSE-DEL NIL))
(COND ((ZEROP /#1LEVEL) (/#1ENTER-OBJ '/# 'PRINC NIL))
(T
(SETQ /#1LEVEL (1- /#1LEVEL))
(COND ((NULL ICODE)
(COND ((NULL OPEN-DEL) (SETQ ICODE 1.))
((SETQ ICODE (FLATC OPEN-DEL))))
(COND ((ATOM (ARG 2.))
(COND (/#1PRINC-ATOMS
(SETQ ICODE
(+ ICODE 1. (FLATC (ARG 2.)))))
((SETQ ICODE
(+ ICODE 1. (FLATSIZE (ARG 2.)))))))))
)
(/#1ENTER-OBJ ICODE NIL 'START)
(PROGN (SETQ /#1FCODE 'NEVER
/#1BCODE 0.)
(/#1ENTER-OBJ (OR OPEN-DEL '|(|) 'PRINC NIL))
((LAMBDA (I J HEAD RTEMP SUBTEMP FCODE)
(PROGN (SETQ I
(COND ((ZEROP /#1LEVEL) 2.)
(/#1PRINLENGTH)))
(SETQ J 2.)
((LAMBDA (U1_ITEM)
((LAMBDA (U1_ITEM)
(SETQ FCODE (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ SUBTEMP U1_ITEM))
(CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ RTEMP U1_ITEM))
TEMP))
(PROG NIL
U1_L (COND ((> J NARGS) (RETURN NIL)))
(SETQ HEAD (ARG J))
(PROGN (COND ((OR (MINUSP I)
(AND (ZEROP I)
(OR (< J NARGS)
(NOT (ATOM HEAD)))))
(PROGN (SETQ /#1FCODE FCODE
/#1BCODE 0.)
(/#1ENTER-OBJ '|...|
'PRINC
NIL))
(RETURN NIL)))
(SETQ /#1FCODE FCODE
/#1BCODE
(COND ((= J NARGS) 0.)
(1.)))
(COND (/#1FORMAT-DISPATCH
(FUNCALL /#1FORMAT-DISPATCH
SUBTEMP
HEAD))
((/#1FORMAT-DISPATCH SUBTEMP HEAD))))
(PROGN (SETQ I (1- I))
(SETQ J (1+ J))
((LAMBDA (U1_ITEM)
((LAMBDA (U1_ITEM)
(SETQ FCODE (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ SUBTEMP U1_ITEM))
(CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ RTEMP U1_ITEM))
RTEMP))
(GO U1_L)))
NIL NIL NIL NIL NIL NIL)
(PROGN (SETQ /#1FCODE 'NEVER
/#1BCODE 0.)
(/#1ENTER-OBJ (OR CLOSE-DEL '|)|) 'PRINC 'END))
(SETQ /#1LEVEL OLEVEL))))
NIL NIL NIL NIL NIL))
(DEFUN /#1FORMAT-HUNK (|U1_ARG1.| HUNK)
((LAMBDA (ICODE TEMP)
(COND ((NOT ((LAMBDA (U1_ITEM)
(AND (NOT (ATOM U1_ITEM))
(PROGN (SETQ ICODE (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ TEMP U1_ITEM)
T)))
|U1_ARG1.|))
(ERROR 'BAD-ARGS-TO-/#1FORMAT-HUNK (LIST |U1_ARG1.| HUNK))))
((LAMBDA (ORINDEX OLEVEL CLOSE-DEL OPEN-DEL END)
(PROGN (SETQ ORINDEX /#1RINDEX)
(SETQ OLEVEL /#1LEVEL)
(SETQ CLOSE-DEL /#1CLOSE-DEL)
(SETQ OPEN-DEL /#1OPEN-DEL)
(SETQ END (1- (HUNKSIZE HUNK))))
(PROGN (SETQ /#1OPEN-DEL NIL) (SETQ /#1CLOSE-DEL NIL))
(COND ((ZEROP /#1LEVEL) (/#1ENTER-OBJ '/# 'PRINC NIL))
((ATOM (SETQ HUNK (/#1RCHECK HUNK)))
(/#1ENTER-OBJ HUNK 'PRINC NIL))
(T
(SETQ /#1LEVEL (1- /#1LEVEL))
(COND ((NULL ICODE)
(COND ((NULL OPEN-DEL) (SETQ ICODE 1.))
((SETQ ICODE (FLATC OPEN-DEL))))
(COND ((ATOM (CXR 1. HUNK))
(COND (/#1PRINC-ATOMS
(SETQ ICODE
(+ ICODE
1.
(FLATC (CXR 1. HUNK)))))
((SETQ ICODE
(+ ICODE
1.
(FLATSIZE (CXR 1. HUNK)))))))))
)
(/#1ENTER-OBJ ICODE NIL 'START)
(PROGN (SETQ /#1FCODE 'NEVER
/#1BCODE 0.)
(/#1ENTER-OBJ (OR OPEN-DEL '{) 'PRINC NIL))
((LAMBDA (I J HEAD RTEMP SUBTEMP FCODE)
(PROGN (SETQ I
(COND ((ZEROP /#1LEVEL) 2.)
(/#1PRINLENGTH)))
(SETQ J 1.)
((LAMBDA (U1_ITEM)
((LAMBDA (U1_ITEM)
(SETQ FCODE (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ SUBTEMP U1_ITEM))
(CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ RTEMP U1_ITEM))
TEMP))
(PROG NIL
U1_L (COND ((> J END) (RETURN NIL)))
(SETQ HEAD (CXR J HUNK))
(PROGN (SETQ TEMP RTEMP)
(COND ((OR (MINUSP I)
(AND (ZEROP I)
(OR (< J END)
(NOT (ATOM HEAD)))))
(PROGN (SETQ /#1FCODE FCODE
/#1BCODE 0.)
(/#1ENTER-OBJ '|...|
'PRINC
NIL))
(RETURN NIL)))
(SETQ /#1FCODE FCODE
/#1BCODE 1.)
(COND (/#1FORMAT-DISPATCH
(FUNCALL /#1FORMAT-DISPATCH
SUBTEMP
HEAD))
((/#1FORMAT-DISPATCH SUBTEMP HEAD))))
(PROGN (SETQ I (1- I))
(SETQ J (1+ J))
((LAMBDA (U1_ITEM)
((LAMBDA (U1_ITEM)
(SETQ FCODE (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ SUBTEMP U1_ITEM))
(CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ RTEMP U1_ITEM))
RTEMP))
(GO U1_L)))
NIL NIL NIL NIL NIL NIL)
(SETQ /#1FCODE (CAAR TEMP)
/#1BCODE 0.)
(COND (/#1FORMAT-DISPATCH
(FUNCALL /#1FORMAT-DISPATCH
(CDAR TEMP)
(CXR 0. HUNK)))
((/#1FORMAT-DISPATCH (CDAR TEMP) (CXR 0. HUNK))))
(PROGN (SETQ /#1FCODE 'NEVER
/#1BCODE 0.)
(/#1ENTER-OBJ (OR CLOSE-DEL '}) 'PRINC 'END))
(PROGN (SETQ /#1RINDEX ORINDEX) (SETQ /#1LEVEL OLEVEL)))))
NIL NIL NIL NIL NIL))
NIL NIL))
(DEFUN /#MAKE-INVERT-QUOTE-FN MACRO (U1_BODY)
((LAMBDA (ATOM OPEN-DEL CLOSE-DEL)
(COND ((NOT ((LAMBDA (U1_ITEM)
(AND (NOT (ATOM U1_ITEM))
(PROGN (SETQ U1_ITEM (CDR U1_ITEM))
(NOT (ATOM U1_ITEM)))
(PROGN (SETQ ATOM (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(NOT (ATOM U1_ITEM)))
(PROGN (SETQ OPEN-DEL (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(OR (AND (NOT (ATOM U1_ITEM))
(PROGN (SETQ CLOSE-DEL
(CAR U1_ITEM))
(NULL (CDR U1_ITEM))))
T))))
U1_BODY))
(ERROR 'BAD-ARGS-TO-/#MAKE-INVERT-QUOTE-FN (LIST U1_BODY))))
((LAMBDA (X Y) (RPLACA X (CAR Y)) (RPLACD X (CDR Y))) U1_BODY
(COND (CLOSE-DEL
(LIST 'DEFUN
(LIST* ATOM '(/#GRIND-FN))
'(TEMP ITEM)
(LIST* 'COND
(LIST* '(CDR ITEM)
(LIST 'SETQ
'/#1OPEN-DEL
(LIST 'QUOTE OPEN-DEL)
'/#1CLOSE-DEL
(LIST 'QUOTE CLOSE-DEL))
'((COND (/#1FORMAT-LIST
(FUNCALL /#1FORMAT-LIST
TEMP
(CDR ITEM)))
((/#1FORMAT-LIST TEMP
(CDR ITEM))))))
'(((COND (/#1FORMAT-LIST
(FUNCALL /#1FORMAT-LIST
TEMP
(CDR ITEM)))
((/#1FORMAT-LIST TEMP ITEM))))))))
((LIST 'DEFUN
(LIST* ATOM '(/#GRIND-FN))
'(TEMP ITEM)
(LIST* 'COND
(LIST* '(AND (CDR ITEM) (NULL (CDDR ITEM)))
(LIST* 'SETQ
'/#1OPEN-DEL
(LIST 'QUOTE OPEN-DEL)
'(/#1CLOSE-DEL '||
/#1LEVEL
(1+ /#1LEVEL)))
'((COND (/#1FORMAT-LIST
(FUNCALL /#1FORMAT-LIST
TEMP
(CDR ITEM)))
((/#1FORMAT-LIST TEMP
(CDR ITEM))))
(SETQ /#1LEVEL (1- /#1LEVEL))))
'(((COND (/#1FORMAT-LIST
(FUNCALL /#1FORMAT-LIST
TEMP
(CDR ITEM)))
((/#1FORMAT-LIST TEMP ITEM)))))))))))
NIL NIL NIL))
(DEFUN '/#GRIND-FN (TEMP ITEM)
(COND ((AND (CDR ITEM) (NULL (CDDR ITEM)))
(SETQ /#1OPEN-DEL '/'
/#1CLOSE-DEL '||
/#1LEVEL (1+ /#1LEVEL))
(COND (/#1FORMAT-LIST (FUNCALL /#1FORMAT-LIST TEMP (CDR ITEM)))
((/#1FORMAT-LIST TEMP (CDR ITEM))))
(SETQ /#1LEVEL (1- /#1LEVEL)))
((COND (/#1FORMAT-LIST (FUNCALL /#1FORMAT-LIST TEMP (CDR ITEM)))
((/#1FORMAT-LIST TEMP ITEM))))))
(DEFUN /#MAKE-INVERT-QUOTE-FN2 MACRO (U1_BODY)
((LAMBDA (INTERNAL-ATOM EXTERNAL-ATOM)
(COND ((NOT ((LAMBDA (U1_ITEM)
(AND (NOT (ATOM U1_ITEM))
(PROGN (SETQ U1_ITEM (CDR U1_ITEM))
(NOT (ATOM U1_ITEM)))
(PROGN (SETQ INTERNAL-ATOM (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(NOT (ATOM U1_ITEM)))
(PROGN (SETQ EXTERNAL-ATOM (CAR U1_ITEM))
(NULL (CDR U1_ITEM)))))
U1_BODY))
(ERROR 'BAD-ARGS-TO-/#MAKE-INVERT-QUOTE-FN2 (LIST U1_BODY))))
((LAMBDA (X Y) (RPLACA X (CAR Y)) (RPLACD X (CDR Y))) U1_BODY
(LIST* 'DEFUN
(LIST* INTERNAL-ATOM '(/#GRIND-FN))
'(TEMP ITEM)
'(/#1ENTER-OBJ 0. NIL 'START)
(LIST* '/#1ENTER-FORMAT&OBJ
''NEVER
'0.
(LIST 'QUOTE EXTERNAL-ATOM)
'('PRINC NIL))
'((/#1ENTER-FORMAT 'NEVER 0.)
(COND (/#1FORMAT-DISPATCH
(FUNCALL /#1FORMAT-DISPATCH NIL (CDR ITEM)))
((/#1FORMAT-DISPATCH NIL (CDR ITEM))))
(/#1ENTER-OBJ '|| 'PRINC 'END)))))
NIL NIL))
(DEFUN `(/#GRIND-FN) (TEMP ITEM)
(/#1ENTER-OBJ 0. NIL 'START)
(PROGN (SETQ /#1FCODE 'NEVER
/#1BCODE 0.)
(/#1ENTER-OBJ '/` 'PRINC NIL))
(SETQ /#1FCODE 'NEVER
/#1BCODE 0.)
(COND (/#1FORMAT-DISPATCH (FUNCALL /#1FORMAT-DISPATCH NIL (CDR ITEM)))
((/#1FORMAT-DISPATCH NIL (CDR ITEM))))
(/#1ENTER-OBJ '|| 'PRINC 'END))
(DEFUN ,(/#GRIND-FN) (TEMP ITEM)
(/#1ENTER-OBJ 0. NIL 'START)
(PROGN (SETQ /#1FCODE 'NEVER
/#1BCODE 0.)
(/#1ENTER-OBJ '/, 'PRINC NIL))
(SETQ /#1FCODE 'NEVER
/#1BCODE 0.)
(COND (/#1FORMAT-DISPATCH (FUNCALL /#1FORMAT-DISPATCH NIL (CDR ITEM)))
((/#1FORMAT-DISPATCH NIL (CDR ITEM))))
(/#1ENTER-OBJ '|| 'PRINC 'END))
(DEFUN ,@(/#GRIND-FN) (TEMP ITEM)
(/#1ENTER-OBJ 0. NIL 'START)
(PROGN (SETQ /#1FCODE 'NEVER
/#1BCODE 0.)
(/#1ENTER-OBJ '/,@ 'PRINC NIL))
(SETQ /#1FCODE 'NEVER
/#1BCODE 0.)
(COND (/#1FORMAT-DISPATCH (FUNCALL /#1FORMAT-DISPATCH NIL (CDR ITEM)))
((/#1FORMAT-DISPATCH NIL (CDR ITEM))))
(/#1ENTER-OBJ '|| 'PRINC 'END))
(DEFUN ,.(/#GRIND-FN) (TEMP ITEM)
(/#1ENTER-OBJ 0. NIL 'START)
(PROGN (SETQ /#1FCODE 'NEVER
/#1BCODE 0.)
(/#1ENTER-OBJ '|,.| 'PRINC NIL))
(SETQ /#1FCODE 'NEVER
/#1BCODE 0.)
(COND (/#1FORMAT-DISPATCH (FUNCALL /#1FORMAT-DISPATCH NIL (CDR ITEM)))
((/#1FORMAT-DISPATCH NIL (CDR ITEM))))
(/#1ENTER-OBJ '|| 'PRINC 'END))
(DEFUN (DEFUN /#GRIND-FN) (TEMP ITEM)
(SETQ TEMP
(COND ((AND ((LAMBDA (U1_ITEM)
(AND (NOT (ATOM U1_ITEM))
(PROGN (SETQ U1_ITEM (CDR U1_ITEM))
(NOT (ATOM U1_ITEM)))
(PROGN (SETQ U1_ITEM (CDR U1_ITEM))
(NOT (ATOM U1_ITEM)))))
ITEM)
(OR (MEMQ (CADR ITEM) '(EXPR FEXPR MACRO))
(MEMQ (CADDR ITEM) '(EXPR FEXPR MACRO))))
/#1DEFUN2-TEMPLATE)
(/#1DEFUN1-TEMPLATE)))
(COND (/#1FORMAT-LIST (FUNCALL /#1FORMAT-LIST TEMP ITEM))
((/#1FORMAT-LIST TEMP ITEM))))
(DEFUN NIL (TEMP ITEM)
(SETQ ITEM
(COND (GRIND-MACROEXPANDED (CADDDR (CDR ITEM)))
(T (CADDDR ITEM))))
(SETQ /#1LEVEL (1+ /#1LEVEL))
(COND (/#1FORMAT-DISPATCH (FUNCALL /#1FORMAT-DISPATCH TEMP ITEM))
((/#1FORMAT-DISPATCH TEMP ITEM)))
(SETQ /#1LEVEL (1- /#1LEVEL)))
(DEFUN (PROG /#GRIND-FN) (UNUSED-TEMPLATE LIST)
(COND (((LAMBDA (OVERVAR_ _ I OVER-ACC)
(PROGN (SETQ OVERVAR_ (CDDR LIST))
(SETQ I 0.)
(SETQ OVER-ACC T))
(PROG NIL
U1_L (COND ((ATOM OVERVAR_) (RETURN OVER-ACC)))
(SETQ _ (CAR OVERVAR_))
(SETQ OVER-ACC
(OR (PROGN (COND ((> I 10.) (RETURN NIL)))
(NOT (ATOM _)))
(RETURN NIL)))
(PROGN (SETQ OVERVAR_ (CDR OVERVAR_)) (SETQ I (1+ I)))
(GO U1_L)))
NIL NIL NIL NIL)
(COND (/#1FORMAT-LIST
(FUNCALL /#1FORMAT-LIST /#1FN-TEMPLATE LIST))
((/#1FORMAT-LIST /#1FN-TEMPLATE LIST))))
(((LAMBDA (ORINDEX OLEVEL DEFAULT-BCODE BCODE ANY-LABS-YET?)
(PROGN (SETQ ORINDEX /#1RINDEX)
(SETQ OLEVEL /#1LEVEL)
(SETQ ANY-LABS-YET? NIL))
(COND (/#1PRINC-ATOMS
(SETQ DEFAULT-BCODE (1+ (FLATC (CAR LIST)))))
((SETQ DEFAULT-BCODE (1+ (FLATSIZE (CAR LIST))))))
(SETQ BCODE DEFAULT-BCODE)
(COND ((ZEROP /#1LEVEL) (/#1ENTER-OBJ '/# 'PRINC NIL))
((ATOM (SETQ LIST (/#1RCHECK LIST)))
(/#1ENTER-OBJ LIST 'PRINC NIL))
(T
(SETQ /#1LEVEL (1- /#1LEVEL))
(/#1ENTER-OBJ 1. NIL 'START)
(PROGN (SETQ /#1FCODE 'NEVER
/#1BCODE 0.)
(/#1ENTER-OBJ '|(| 'PRINC NIL))
((LAMBDA (I REST HEAD K)
(PROGN (SETQ I
(COND ((ZEROP /#1LEVEL) 2.)
(/#1PRINLENGTH)))
((LAMBDA (U1_ITEM)
(SETQ HEAD (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ REST U1_ITEM))
LIST)
(SETQ K 1.))
(PROG NIL
U1_L (PROGN (COND ((OR (MINUSP I)
(AND (ZEROP I)
(OR REST
(NOT (ATOM HEAD)))))
(PROGN (SETQ /#1FCODE 'NEVER
/#1BCODE 0.)
(/#1ENTER-OBJ '|...|
'PRINC
NIL))
(RETURN NIL)))
(COND ((MINUSP K)
(COND ((AND (ATOM HEAD) HEAD)
(COND (/#1PRINC-ATOMS
(SETQ BCODE
(- BCODE 1. (FLATC HEAD))))
((SETQ BCODE
(- BCODE 1. (FLATSIZE HEAD)))))
(PROGN (SETQ /#1FCODE
(COND (ANY-LABS-YET? 'NEVER)
('ALWAYS))
/#1BCODE 1.)
(/#1ENTER-OBJ HEAD
(COND (/#1PRINC-ATOMS 'PRINC)
('PRIN1))
NIL))
(SETQ ANY-LABS-YET? T))
(T
(COND ((NOT ANY-LABS-YET?)
(PROGN (SETQ
/#1FCODE 'ALWAYS
/#1BCODE DEFAULT-BCODE)
(/#1ENTER-OBJ '|| NIL NIL)))
(T
(PROGN (SETQ
/#1FCODE 'NEVER
/#1BCODE (MAX 0. BCODE))
(/#1ENTER-OBJ '|| NIL NIL))
(PROGN (SETQ BCODE
DEFAULT-BCODE)
(SETQ ANY-LABS-YET? NIL))))
(SETQ /#1FCODE 'NEVER
/#1BCODE
(COND ((NULL REST)
0.)
(1.)))
(COND (/#1FORMAT-DISPATCH
(FUNCALL
/#1FORMAT-DISPATCH
NIL
HEAD))
((/#1FORMAT-DISPATCH
NIL
HEAD))))))
(T
(SETQ /#1FCODE 'NEVER
/#1BCODE
(COND ((NULL REST) 0.)
(1.)))
(COND (/#1FORMAT-DISPATCH
(FUNCALL /#1FORMAT-DISPATCH
/#11LEVEL-BLOCK-TEMPLATE
HEAD))
((/#1FORMAT-DISPATCH
/#11LEVEL-BLOCK-TEMPLATE
HEAD)))))
(COND ((NULL REST) (RETURN NIL)))
(COND ((NOT (EQ (TYPEP (SETQ REST
(/#1RCHECK REST)))
'LIST))
(PROGN (SETQ /#1FCODE 'NEVER
/#1BCODE 1.)
(/#1ENTER-OBJ '|.|
'PRINC
NIL))
(SETQ /#1FCODE 'NEVER
/#1BCODE 0.)
(COND (/#1FORMAT-DISPATCH
(FUNCALL /#1FORMAT-DISPATCH
NIL
REST))
((/#1FORMAT-DISPATCH NIL
REST)))
(RETURN NIL))))
(PROGN (SETQ I (1- I))
((LAMBDA (U1_ITEM)
(SETQ HEAD (CAR U1_ITEM))
(SETQ U1_ITEM (CDR U1_ITEM))
(SETQ REST U1_ITEM))
REST)
(SETQ K (1- K)))
(GO U1_L)))
NIL NIL NIL NIL)
(PROGN (SETQ /#1FCODE 'NEVER
/#1BCODE 0.)
(/#1ENTER-OBJ '|)| 'PRINC 'END))
(PROGN (SETQ /#1RINDEX ORINDEX)
(SETQ /#1LEVEL OLEVEL)))))
NIL NIL NIL NIL NIL))))
(PUTPROP 'DO (GET 'PROG '/#GRIND-FN) '/#GRIND-FN)
(DEFUN /#1ENTER-OBJ (OBJ PCODE LCODE)
((LAMBDA (FLAG LENGTH)
(PROGN (SETQ FLAG
(+ (COND ((EQ PCODE 'PRIN1) (PROGN 4096.))
((EQ PCODE 'PRINC) (PROGN 2048.))
(0.))
(COND ((EQ /#1FCODE 'NEVER) (PROGN 512.))
((EQ /#1FCODE 'NORMAL) (PROGN 128.))
((EQ /#1FCODE 'TBLOCK) (PROGN 1024.))
((EQ /#1FCODE 'BLOCK) (PROGN 256.))
((PROGN 64.)))
(COND ((EQ LCODE 'START) (PROGN 8192.))
((EQ LCODE 'END)
(+ 49152.
(ARRAYCALL FIXNUM /#1BCODESTACK /#1SUPPTR)))
((+ 32768. /#1BCODE)))))
(SETQ LENGTH
(COND ((NOT (ZEROP (BOOLE 1. 8192. FLAG))) 0.)
((NOT (ZEROP (BOOLE 1. 4096. FLAG)))
(+ (BOOLE 1. 63. FLAG) (FLATSIZE OBJ)))
((NOT (ZEROP (BOOLE 1. 2048. FLAG)))
(+ (BOOLE 1. 63. FLAG) (FLATC OBJ)))
((BOOLE 1. 63. FLAG)))))
(COND (/#1EXPLODING
(COND ((NOT (ZEROP (BOOLE 1. 2048. FLAG)))
(SETQ /#1EXPLODE-RESULT
(NRECONC (EXPLODEC OBJ) /#1EXPLODE-RESULT)))
((NOT (ZEROP (BOOLE 1. 4096. FLAG)))
(SETQ /#1EXPLODE-RESULT
(NRECONC (EXPLODE OBJ) /#1EXPLODE-RESULT))))
((LAMBDA (I)
(SETQ I (BOOLE 1. 63. FLAG))
(PROG NIL
U1_L (COND ((NOT (PLUSP I)) (RETURN NIL)))
(SETQ /#1EXPLODE-RESULT
(CONS '| | /#1EXPLODE-RESULT))
(SETQ I (1- I))
(GO U1_L)))
NIL)
(COND ((NOT (ZEROP (BOOLE 1. 8192. FLAG)))
(PROGN (SETQ /#1SUPPTR (1+ /#1SUPPTR))
(STORE (ARRAYCALL FIXNUM
/#1BCODESTACK
/#1SUPPTR)
/#1BCODE)))
((NOT (ZEROP (BOOLE 1. 16384. FLAG)))
(SETQ /#1SUPPTR (1- /#1SUPPTR)))))
(T
(PROGN (SETQ /#1INPTR (1+ /#1INPTR))
(STORE (ARRAYCALL FIXNUM /#1SUPSTACK /#1SUPPTR)
(1+ (ARRAYCALL FIXNUM /#1SUPSTACK /#1SUPPTR))))
(COND ((NOT (< /#1INPTR /#1SIZE))
(COND ((< /#1PP 10.)
(SETQ /#1SIZE (+ /#1SIZE 10.))
(*REARRAY /#1OBJ
(CAR (ARRAYDIMS /#1OBJ))
/#1SIZE)
(*REARRAY /#1FLAG
(CAR (ARRAYDIMS /#1FLAG))
/#1SIZE)
(*REARRAY /#1LENGTH
(CAR (ARRAYDIMS /#1LENGTH))
/#1SIZE))
(T
((LAMBDA (J I)
(PROGN (SETQ J /#1PP) (SETQ I 0.))
(PROG NIL
U1_L (COND ((= J /#1SIZE) (RETURN NIL)))
(PROGN (STORE (ARRAYCALL NIL
/#1OBJ
I)
(ARRAYCALL NIL /#1OBJ J))
(STORE (ARRAYCALL FIXNUM
/#1FLAG
I)
(ARRAYCALL FIXNUM
/#1FLAG
J))
(STORE (ARRAYCALL FIXNUM
/#1LENGTH
I)
(ARRAYCALL FIXNUM
/#1LENGTH
J)))
(PROGN (SETQ J (1+ J))
(SETQ I (1+ I)))
(GO U1_L)))
NIL NIL)
(PROGN (SETQ /#1INPTR (- /#1INPTR /#1PP))
(SETQ /#1PP 0.))))))
(PROGN (STORE (ARRAYCALL NIL /#1OBJ /#1INPTR) OBJ)
(STORE (ARRAYCALL FIXNUM /#1FLAG /#1INPTR) FLAG)
(STORE (ARRAYCALL FIXNUM /#1LENGTH /#1INPTR) LENGTH))
((LAMBDA (I J)
(PROGN (SETQ I /#1SUPPTR)
(SETQ J
(- /#1INPTR (ARRAYCALL FIXNUM /#1SUPSTACK I))))
(PROG NIL
U1_L (COND ((OR (ZEROP I) (< J /#1PP)) (RETURN NIL)))
(STORE (ARRAYCALL FIXNUM /#1LENGTH J)
(+ LENGTH (ARRAYCALL FIXNUM /#1LENGTH J)))
(PROGN (SETQ I (1- I))
(SETQ J
(- J (ARRAYCALL FIXNUM /#1SUPSTACK I))))
(GO U1_L)))
NIL NIL)
(COND ((NOT (ZEROP (BOOLE 1. 64. FLAG)))
((LAMBDA (I J)
(PROGN (SETQ I /#1SUPPTR)
(SETQ J
(- /#1INPTR
(ARRAYCALL FIXNUM /#1SUPSTACK I))))
(PROG NIL
U1_L (COND ((OR (ZEROP I) (< J /#1PP))
(RETURN NIL)))
(STORE (ARRAYCALL FIXNUM /#1FLAG J)
(+ 65536.
(ARRAYCALL FIXNUM /#1FLAG J)))
(PROGN (SETQ I (1- I))
(SETQ J
(- J
(ARRAYCALL FIXNUM
/#1SUPSTACK
I))))
(GO U1_L)))
NIL NIL)))
(COND ((NOT (ZEROP (BOOLE 1. 8192. FLAG)))
(SETQ /#1SUPPTR (1+ /#1SUPPTR))
(COND ((NOT (< /#1SUPPTR /#1SUPSIZE))
(SETQ /#1SUPSIZE (+ /#1SUPSIZE 10.))
(*REARRAY /#1SUPSTACK
(CAR (ARRAYDIMS /#1SUPSTACK))
/#1SUPSIZE)
(*REARRAY /#1INDSTACK
(CAR (ARRAYDIMS /#1INDSTACK))
/#1SUPSIZE)
(*REARRAY /#1BCODESTACK
(CAR (ARRAYDIMS /#1BCODESTACK))
/#1SUPSIZE)))
(PROGN (STORE (ARRAYCALL FIXNUM
/#1SUPSTACK
/#1SUPPTR)
0.)
(STORE (ARRAYCALL FIXNUM
/#1BCODESTACK
/#1SUPPTR)
/#1BCODE)))
((NOT (ZEROP (BOOLE 1. 16384. FLAG)))
((LAMBDA (I)
(COND ((NOT (> /#1PP I))
(STORE (ARRAYCALL FIXNUM /#1FLAG I)
(+ 32768.
(ARRAYCALL FIXNUM /#1FLAG I))))))
(- /#1INPTR (ARRAYCALL FIXNUM /#1SUPSTACK /#1SUPPTR)))
(PROGN (SETQ /#1SUPPTR (1- /#1SUPPTR))
(STORE (ARRAYCALL FIXNUM
/#1SUPSTACK
/#1SUPPTR)
(+ (ARRAYCALL FIXNUM
/#1SUPSTACK
/#1SUPPTR)
(ARRAYCALL FIXNUM
/#1SUPSTACK
(1+ /#1SUPPTR)))))))
(/#1PRINTOUT))))
NIL NIL)
NIL)
(DEFUN /#1PRINTOUT NIL
((LAMBDA (FLAG)
(PROG NIL
U1_L (COND ((> /#1PP /#1INPTR) (RETURN NIL)))
(SETQ FLAG (ARRAYCALL FIXNUM /#1FLAG /#1PP))
(COND ((AND (NOT (ZEROP (BOOLE 1. 1024. FLAG)))
(NOT (ZEROP (BOOLE 1. 32768. FLAG)))
(= /#1TABSIZE 1.))
((LAMBDA (N I MAX SPACE)
(PROGN (SETQ N
(MAX 2.
(ARRAYCALL FIXNUM /#1LENGTH /#1PP)))
(SETQ I 0.)
(SETQ MAX
((LAMBDA (J FLAG)
(SETQ J /#1PP)
(PROG NIL
U1_L (COND ((> J /#1INPTR)
(RETURN N)))
(SETQ FLAG
(ARRAYCALL FIXNUM
/#1FLAG
J))
(PROGN (COND ((= I 0.)
(SETQ N (MAX N (ARRAYCALL FIXNUM /#1LENGTH J)))))
(COND ((NOT (ZEROP (BOOLE
1.
8192.
FLAG)))
(SETQ I (1+ I)))
((NOT (ZEROP (BOOLE
1.
16384.
FLAG)))
(SETQ I (1- I)))))
(SETQ J (1+ J))
(GO U1_L)))
NIL NIL))
(SETQ SPACE
(- /#1LINELEN
(ARRAYCALL FIXNUM
/#1INDSTACK
/#1INDPTR))))
(PROGN (SETQ MAX (MIN SPACE (+ MAX (// MAX 5.))))
(SETQ /#1TABSIZE (// SPACE (// SPACE MAX)))
(SETQ /#1TABOFFSET
(- (\ SPACE /#1TABSIZE) /#1TABSIZE))))
NIL NIL NIL NIL)))
(COND ((NOT /#1ATSTART?)
(COND ((AND (NOT (ZEROP (BOOLE 1. 1024. FLAG)))
(NOT (ZEROP (BOOLE 1. 32768. FLAG))))
((LAMBDA (J)
(PROGN (SETQ /#1PENDING (+ /#1PENDING J))
(SETQ /#1FREELEN (- /#1FREELEN J))))
(\ (- /#1FREELEN /#1TABOFFSET) /#1TABSIZE))))
(COND ((OR (NOT (ZEROP (BOOLE 1. 64. FLAG)))
(NOT (ZEROP (BOOLE 1. 128. FLAG)))
(AND (OR (NOT (ZEROP (BOOLE 1. 256. FLAG)))
(NOT (ZEROP (BOOLE 1. 1024. FLAG))))
(OR /#1WENTUP?
(NOT (ZEROP (BOOLE 1. 65536. FLAG)))
(AND (> (ARRAYCALL FIXNUM
/#1LENGTH
/#1PP)
/#1FREELEN)
(< /#1FREELEN
(- /#1LINELEN
(ARRAYCALL FIXNUM
/#1INDSTACK
/#1INDPTR))))))
(AND (NOT (ZEROP (BOOLE 1. 512. FLAG)))
(NOT (NOT (ZEROP (BOOLE 1. 8192. FLAG))))
(> (ARRAYCALL FIXNUM /#1LENGTH /#1PP)
(+ 4. /#1FREELEN))))
(PROGN (SETQ /#1ATSTART? T)
(SETQ /#1WENTUP? NIL)
(SETQ /#1CLINE (1+ /#1CLINE))
(SETQ /#1PENDING
(ARRAYCALL FIXNUM
/#1INDSTACK
/#1INDPTR))
(SETQ /#1FREELEN
(- /#1LINELEN /#1PENDING)))
(COND ((> /#1CLINE /#1PRINENDLINE)
(THROW '|#1prinendline exceeded|
/#1PRINTABORT)))
(COND (/#1PRINTING? (TERPRI /#1FILES))
((SETQ /#1PRINTING?
(NOT (> /#1PRINSTARTLINE /#1CLINE)))
(SETQ /#1PENDING (- /#1PENDING /#1CP))))))))
(COND ((AND (NOT (ZEROP (BOOLE 1. 8192. FLAG)))
(OR (NOT (ZEROP (BOOLE 1. 65536. FLAG)))
(> (ARRAYCALL FIXNUM /#1LENGTH /#1PP)
/#1FREELEN)))
(PROGN (SETQ /#1INDPTR (1+ /#1INDPTR))
(STORE (ARRAYCALL FIXNUM /#1INDSTACK /#1INDPTR)
((LAMBDA (I)
(COND ((> I /#1MAXINDENTLEN)
(+ /#1CP
(// (- /#1LINELEN /#1CP)
5.)
(- I /#1MAXINDENTLEN)))
(I)))
(MAX /#1CP
(+ (ARRAYCALL NIL /#1OBJ /#1PP)
(- /#1LINELEN /#1FREELEN)))))
(SETQ /#1PP (1+ /#1PP))
(SETQ /#1TABSIZE 1.)))
((NOT (ZEROP (BOOLE 1. 32768. FLAG)))
(PROGN (SETQ /#1FREELEN
(- /#1FREELEN
(ARRAYCALL FIXNUM /#1LENGTH /#1PP)))
(SETQ /#1ATSTART? NIL))
((LAMBDA (I)
(SETQ I 0.)
(PROG NIL
U1_L (COND ((NOT (ZEROP (BOOLE 1. 8192. FLAG)))
(SETQ I (1+ I)))
(T
(COND ((NOT (ZEROP (BOOLE 1.
16384.
FLAG)))
(SETQ I (1- I))))
(COND (/#1PRINTING?
((LAMBDA (J)
(SETQ J /#1PENDING)
(PROG NIL
U1_L (COND ((NOT (PLUSP J))
(RETURN NIL)))
(TYO 32. /#1FILES)
(SETQ J (1- J))
(GO U1_L)))
NIL)
(COND ((NOT (ZEROP (BOOLE 1.
2048.
FLAG)))
(PRINC (ARRAYCALL NIL
/#1OBJ
/#1PP)
/#1FILES))
((NOT (ZEROP (BOOLE 1.
4096.
FLAG)))
(PRIN1 (ARRAYCALL NIL
/#1OBJ
/#1PP)
/#1FILES)))))
(SETQ /#1PENDING (BOOLE 1. 63. FLAG))))
(SETQ /#1PP (1+ /#1PP))
(COND ((ZEROP I) (RETURN NIL))
((MINUSP I)
(PROGN (SETQ /#1INDPTR (1- /#1INDPTR))
(SETQ /#1WENTUP? T)
(SETQ /#1TABSIZE 64000.))
(RETURN NIL)))
(SETQ FLAG (ARRAYCALL FIXNUM /#1FLAG /#1PP))
(GO U1_L)))
NIL))
((RETURN NIL)))
(GO U1_L)))
NIL))
))
Reference in New Issue View Git Blame Copy Permalink