From 02d9eb9851105ab2f83244a2aae177ba9e77e44e Mon Sep 17 00:00:00 2001 From: Eric Swenson Date: Tue, 2 Oct 2018 23:18:22 -0700 Subject: [PATCH] Built a bunch of missing FASL files from LIBLSP. Resolves #1287. --- Makefile | 2 +- build/lisp.tcl | 39 + doc/libdoc/lddt.info | 158 + src/ken/decla2.186 | 104 + src/ken/declar.67 | 15 + src/ken/declar.68 | 15 + src/libdoc/#print.rcw3 | 4251 +++++++++++++++++++++++ src/libdoc/bssq.gls5 | 50 + src/libdoc/lddt.ejs211 | 607 ++++ src/libdoc/{ndone.rvb1 => ndone.ejs2} | 28 +- src/libdoc/{prime.pratt1 => prime.ejs2} | 19 +- src/libdoc/rdtags.byron3 | 220 ++ src/libdoc/{step.rich12 => step.ejs13} | 3 + src/libdoc/utils.ejs2 | 22 + 14 files changed, 5509 insertions(+), 24 deletions(-) create mode 100755 doc/libdoc/lddt.info create mode 100644 src/ken/decla2.186 create mode 100644 src/ken/declar.67 create mode 100644 src/ken/declar.68 create mode 100644 src/libdoc/#print.rcw3 create mode 100755 src/libdoc/bssq.gls5 create mode 100644 src/libdoc/lddt.ejs211 rename src/libdoc/{ndone.rvb1 => ndone.ejs2} (70%) mode change 100755 => 100644 rename src/libdoc/{prime.pratt1 => prime.ejs2} (75%) mode change 100755 => 100644 create mode 100644 src/libdoc/rdtags.byron3 rename src/libdoc/{step.rich12 => step.ejs13} (98%) create mode 100644 src/libdoc/utils.ejs2 diff --git a/Makefile b/Makefile index db70998f..76879dd7 100644 --- a/Makefile +++ b/Makefile @@ -26,7 +26,7 @@ SRC = syseng sysen1 sysen2 sysen3 sysnet kshack dragon channa \ draw wl taa tj6 budd sharem ucode rvb kldcp math as imsrc gls demo \ macsym lmcons dmcg hack hibou agb gt40 rug maeda ms kle aap common \ fonts zork 11logo kmp info aplogo bkph bbn pdp11 chsncp sca music1 \ - moon teach + moon teach ken DOC = info _info_ sysdoc sysnet syshst kshack _teco_ emacs emacs1 c kcc \ chprog sail draw wl pc tj6 share _glpr_ _xgpr_ inquir mudman system \ xfont maxout ucode moon acount alan channa fonts games graphs humor \ diff --git a/build/lisp.tcl b/build/lisp.tcl index 7c99a8da..6b890a41 100644 --- a/build/lisp.tcl +++ b/build/lisp.tcl @@ -942,6 +942,45 @@ respond "*" ":midas liblsp;_gsb;ttyvar\r" respond "Use what filename instead?" "lisp;\r" expect ":KILL" +respond "*" ":midas liblsp;_libdoc;aryadr\r" +expect ":KILL" +respond "*" ":midas liblsp;_libdoc;bssq\r" +expect ":KILL" + +respond "*" "complr\013" +respond "_" "liblsp;_libdoc;lddt\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "liblsp;_libdoc;ndone\r" +respond "_" "\032" +type ":kill\r" + +respond "*" ":link graphs;graph3 fasl,liblsp\r" +respond "*" ":link graphs;plot3 fasl,liblsp\r" +respond "*" ":link graphs;plot fasl,liblsp\r" +respond "*" "complr\013" +respond "_" "liblsp;_libdoc;plot\r" +respond "_" "liblsp;_libdoc;plot3\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "liblsp;_libdoc;prime\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "liblsp;_libdoc;step\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "liblsp;_libdoc;utils\r" +respond "_" "\032" +type ":kill\r" + # DEFSET respond "*" "complr\013" respond "_" "lisp;_nilcom;defset\r" diff --git a/doc/libdoc/lddt.info b/doc/libdoc/lddt.info new file mode 100755 index 00000000..f7acc5bd --- /dev/null +++ b/doc/libdoc/lddt.info @@ -0,0 +1,158 @@ +Information on LDDT: + LDDT is a package of functions for manipulating inferior jobs using +the HUMBLE package (NEWIO) or JOBLAP (OLDIO). The source is MC:JLK;LDDT > +Many of the functions are used in a fashion similar to DDT commands of the +same name, e.g. (g 69) in LDDT is like 69G in DDT. + +Special variables in LDDT: + +NULL - Has a value of (ASCII 0) for surreptitious returns. + +*BREAK16-FUNCTION - Its value is an atom which is applied to the + effective address of .BREAK 16, requests from the inferior. + This is the primary communication mechanism from the inferior + job to LISP routines in the superior LISP. + +*VALUE - Its value is an atom whose function property is a handler for + .VALUE returns from an inferior. + +*BREAK - Its value is an atom whose function property handles .BREAK's + (calls .BREAK 16, handler, .BREAK 12, handler, etc.) + +CURRENT-JOB - A pointer to the current JOB's JOB-array + +DDT-READTABLE - A readtable for reading commands in DDT syntax. + (not developed very far yet). + +JOB-STACK - A list used as a stack for pushing the current job while + handling job interrupts. + +LISP-CURSORPOS - Saved cursorposition when TTY is passed to TECO. + +RETURNED-MSG - Message printed on the bottom line of the screen when + the inferior returns with ^Z. + +OUTCRCT - Output character count (FILEPOS doesn't work on output files) + +J*STADR - 23 - The element of job-arrays containing the start-address. + +J*CRUFT - 3 - The job-array slot containing the job's PLIST + +JOB-INTERRUPT-LIST - A list of atoms representing, in numerical order, names + of interrupts. The values of these atoms are handlers for + these particular interrupts. +JOB-RING - The ring of current jobs. + +JOB-INFORM - A file-array to the tty for informing the user of job + behavior (.values, .ilopr's, etc not otherwise handled). + +CRLF - CRLF. For routines that want to return quietly. + +JOB-INTERRUPT-LIST : +TYPEIN ^ZTYPED BADPI AROV 340DPY ILOPR SYSDED *VALUE IOC ILUAD *BREAK +1PROC SLOWCLOCK MPV MAR LTPEN PDLOV CLI RESTR SYSDBG ARMTP1 ARMTP2 +ARMTP3 SYSUUO PURINS PURPG ARFOV PARERR PITTY PIATY PIDCL <4/.5> +<4/.6> RUNTIM REALTM + +EXTERNAL FUNCTIONS (in HUMBLE or JOBLAP): + +p - Start and give the tty to the current job. + +JOB-USET-WRITE - Write a user variable for the current job. + (see also LIBLSP;LUSETS MACRO) + +JOB-USET-READ - Read a user variable for the current job. + +EXAMINE-JOB - read a location in the inferior job. + +DEPOSIT-JOB - Deposit a value into some location of the current inferior job. + +KILL-JOB - Expunge the current job. + +VALUE-STRING - Read a string of characters from the inferior's memory + terminated with ^@. + +*ATTY - Give the TTY to the current inferior job. + +*DTTY - Take the TTY back from the inferior that has it. + +CREATE-JOB - Create a job. + +SELECT-JOB - Select a job to be the current job. + +Functions in LDDT: + + PRINJ - Princ to the JOB-INFORM channel + + TERPRJ - TERPRI on the JOB-INFORM channel + + JOB-INTERRUPT-HANDLER - Handler for job interrupts + + ARBITRATE-INTERRUPTS - Arbitrate interrupts (decide which order to handle + simultaneous interrupts. Current just takes them + in numerical order). + + PIRQC-DECODE - Decode PIRQC into interrupt "atoms" on the + JOB-INTERRUPTS-LIST + + RANDOM-CLASS1-INTERRUPT - Handler for all unhandled class 1 interrupts. + + ^Z-INTERRUPT - Handler for ^Z typed in the inferior (flush type-ahead). + + DEFERRED-CALL - Handle deferred-call (don't flush type-ahead). + + CALC-EFF-ADR - calculates the effective address in a word. + + *VALUE-HANDLER - Default handler for .VALUE's + + *VALUE0 - Handler for .VALUE 0 + + *VALUE-STRING - Get string specified by .VALUE + + PUT-JCL - set the JCL for a job. + + DDT - enter a DDT like command reader (doesn't work yet) + + DDT-ALTMODE-MACRO - Read macro for DDT commands beginning with altmode + + DDT-COLON-MACRO - Read macro for DDT colon commands + + :JCL -Set the JCL for a job + + :PROCEED - proceed a job, but keep the tty. + + ^P - Alias for PROCEED. + + :CONTIN - Continue an existing job, giving it the tty. + + P - Alias for CONTIN. + + :GZP - Start and PROCEED a job. + + :START - Start a job. + + START-JOB -Start job. 2 args: location and TTY flag + (NIL= don't giveup the tty, otherwise give inferior + the tty). + CONTINUE-JOB - Continue existing job, One arg - TTY flags as above. + + G - Alias for START + + J - Select next job in the job ring. + + J - Rename the current job. + + *BREAK-HANDLER - Default handler for .BREAK's + + *BREAK16-HANDLER - Default Handler for .BREAK 16, + + *BREAK12-HANDLER - Default Handler for .BREAK 12, + + JOB-RETURNED-TTY - Inform the user that an inferior job has returned + the TTY. + + PUSH-SELECT-JOB - Push the current job on the stack and select the + job specified as an argument. + + POP-SELECT-JOB - Pop a job off the job-stack and select it as current. + diff --git a/src/ken/decla2.186 b/src/ken/decla2.186 new file mode 100644 index 00000000..71d9d683 --- /dev/null +++ b/src/ken/decla2.186 @@ -0,0 +1,104 @@ +;;-*-lisp-*- +;;the declaration to the compiler for Director system code is here + +(declare ;;(macros t) removed since (defun (foo macro) ...) does it for me + (mapex t) + ;;want all mapped functions open coded so that macros are never double expanded + (muzzled t) ;;for the time being not worried about number optimations + (setq nfunvars t)) ;;i use funcall to make functional variables explicit + +(defun defcomment macro (nil) nil) ;this is useful mostly for tags + +(defcomment decla2) ;for tags + +(declare (special :penstate :xorstate :eraserstate :heading :colors :pencolor :erasercolor + :last-runtime :xcor :ycor :turtle-windows :outline + :tvrtle-file-name pi-over-180 :e + :last-thing-upped :tvstep :reasonable-size-interpolation + turtle-picture-right turtle-picture-top)) ;;these are tvrtle variables + +(declare (special compiled-pattern-of-name ask-all-result)) ;;for expansion of ask-all + +(defcomment *lexpr) + +(declare + (*lexpr turtlesize tvsize mw hw sw range bearing eval-define dicks-print dicks-prin1 /#princ + director-load merge-suggestions gen-number time-to-walk copy test-part-of-pattern + estimate-time-to-move-character find-screen-coordinate-of ideal-number-of-cycles + some-number-of-cycles estimate-time-for-cycles ask-macro predicate-of-pattern + type print-without-parens princ-without-parens princ+blank insert-receive + update-compiled-transmission compile-cases-cleverly extractor-of-difference + update-all-dependent-selectors update-appropriate-dependent-compiled-transmissions + compile-file compile-files defunize compile-actor make-actor union intersect + collect-all-variable-names collect-all-memory-items super-member)) + +(defcomment special) + +(declare + (special :self :message :compiler-on ? :old-value :new-value :files-already-read + :protected-actors :compile-simple-transmissions :help-storage-place + :default-compilation-target :print-load-messages :reset-default-compilation-target? + :reversed-already? no-value nothing-found :frames-per-second :ticks-per-frame + :compiled-movies :line-length :actors-currently-traced :actor-of-method-being-run + :dont-want-to-see-warnings-from :use-expansions :replace-old-methods + :message-not-understood :actor-not-defined :ask-type-macros :warning-break + :color-tvrtle-file-name :method-being-run :circular-list-of-nils + :actor+skipped-methods :skip-current-method? :collecting-actors :actors-collected + :expansion-number-indicator :maximum-number-of-matching-methods + :make-method-selectors :internal-methods-first + :compilation-target :update-all-dependent-selectors :non-inheritable-variable-names)) + +(declare (special arg-package-appearance-drawer)) ;;for compiling movies + + +;;for compiling actors +(declare (special :help-file-object :macros-file-object + :want-to-make-help-file :collecting-actors-in-this-file) + (special :compile-all-together :stuff-not-printed)) + +(declare (special :insert-methods-at-end :old-macro-form :whole-macro-form)) + + + ;;when fast-compile is declared in a file the special compiling macros are activated + + +(declare + (setq :displace-macro-calls t) ;;so that macro calls are expanded only once + (setq :protected-actors nil) ;;anybody can be redefined while compiling + (cond ((and (boundp 'clever-compile) + clever-compile) ;;on the c switch in compiler version 769 and > + (setq errset t) ;since bugs pop up so often + ((lambda (*rset nouuo) + (cond ((status features director-loader)) ;;already loaded + (t (load '|ai:ken;ken lisp|) + (load '|ai:ken;load|) + (director '(ani direct))))) ;;both systems should be available + nil nil) + (setq :compile-all-together nil) ;;so that it makes Macros, Depends and Help + (coutput (append '(comment fast compiling) (status crfile))) + (or (member (full-file-name (status crfile)) :files-already-read) + (director-load-and-return-actors (status crfile) '(to define its actors))) + (compiler-switch t) + (setq :reset-default-compilation-target? t ;;this is the default and should + :default-compilation-target 'something) ;;be reset in the file + (setq :use-expansions nil)))) + +(declare (or (status features gcdemn) (load '|ken;gcdemn|))) + +(declare (cond ((not (status features dicks-printer)) + (load '|liblsp;#print|) + (sstatus features dicks-printer)))) + +(declare (or (status features henrys-read-macros) (load '|ken1;reamac|))) + +(declare (or (status features macro-expansion) (load '|ken1;expmac|))) + +;;(declare (or (status features henrys-macros) (load '|ken1;hmac|))) + +(declare (or (status features director-macros) (load '|ken1;macros|))) + +(declare (or (status features kens-utilities) (load '|ken1;util|))) + +(declare (or (status features director) (load'|ken1;drect|))) +;;these files are needed to complete macro defintions (ask for example) + diff --git a/src/ken/declar.67 b/src/ken/declar.67 new file mode 100644 index 00000000..10339cf8 --- /dev/null +++ b/src/ken/declar.67 @@ -0,0 +1,15 @@ +;; -*-lisp-*- +;;when compiling this should include decla2 > where the real declarations are + + +(defun declarations-only-when-needed macro (useless) + (cond ((or (status features ncomplr) ;;old way + (status features complr)) ;;new way + (sstatus feature complr) ;;since some now expect the new way but still might + ;;run in an older compiler + (sstatus feature ncomplr) ;;until I recompile my macros and drect > + '(include |ai:ken;decla2 >|)))) + +(declarations-only-when-needed) + + diff --git a/src/ken/declar.68 b/src/ken/declar.68 new file mode 100644 index 00000000..83c606b9 --- /dev/null +++ b/src/ken/declar.68 @@ -0,0 +1,15 @@ +;; -*-lisp-*- +;;when compiling this should include decla2 > where the real declarations are + + +(defun declarations-only-when-needed macro (useless) + (cond ((or (status features ncomplr) ;;old way + (status features complr)) ;;new way + (sstatus feature complr) ;;since some now expect the new way but still might + ;;run in an older compiler + (sstatus feature ncomplr) ;;until I recompile my macros and drect > + '(include |ken;decla2 >|)))) + +(declarations-only-when-needed) + + diff --git a/src/libdoc/#print.rcw3 b/src/libdoc/#print.rcw3 new file mode 100644 index 00000000..6106c134 --- /dev/null +++ b/src/libdoc/#print.rcw3 @@ -0,0 +1,4251 @@ +;-*-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)) + + )) diff --git a/src/libdoc/bssq.gls5 b/src/libdoc/bssq.gls5 new file mode 100755 index 00000000..67ad4057 --- /dev/null +++ b/src/libdoc/bssq.gls5 @@ -0,0 +1,50 @@ +TITLE BUBBLING ASSQ + +;;; BSSQ IS LIKE ASSQ, BUT IF IT FINDS A PAIR IT BUBBLES IT +;;; TOWARD THE FRONT OF THE A-LIST BY DOING TWO RPLACA'S. + +.FASL +.INSRT SYS:.FASL DEFS + +.ENTRY BSSQ SUBR 0003 ;2 ARGS +BSSQ: MOVS C,(B) ;WORKS FOR SECOND ARG = NIL! + HLRZ T,(C) + CAIN T,(A) + JRST BSSQ7 +BSSQ0: HLRZ C,C + JUMPE C,BSSQ7 + MOVS AR1,(C) + HLRZ T,(AR1) + CAIN T,(A) + JRST BSSQ2 + HLRZ AR1,AR1 + JUMPE AR1,BSSQ8 + MOVS B,(AR1) + HLRZ T,(B) + CAIN T,(A) + JRST BSSQ4 + HLRZ B,B + JUMPE B,BSSQ9 + MOVS C,(B) + HLRZ T,(C) + CAIE T,(A) + JRST BSSQ0 + HLRZ T,(AR1) + HRLM C,(AR1) + HRLM T,(B) +BSSQ7: MOVEI A,(C) + POPJ P, + +BSSQ2: HLRZ T,(B) + HRLM AR1,(B) + HRLM T,(C) +BSSQ8: MOVEI A,(AR1) + POPJ P, + +BSSQ4: HLRZ T,(C) + HRLM B,(C) + HRLM T,(AR1) +BSSQ9: MOVEI A,(B) + POPJ P, + +FASEND diff --git a/src/libdoc/lddt.ejs211 b/src/libdoc/lddt.ejs211 new file mode 100644 index 00000000..752f1ef3 --- /dev/null +++ b/src/libdoc/lddt.ejs211 @@ -0,0 +1,607 @@ +;;; -*-LISP-*- +; NEWIO LISP DDT +; +; This file contains functions to manipulate I.T.S. jobs from LISP using +; the primitives defined in NEWIO LISP. A package for interacting with TECO +; is available as (LIBLSP;LISPT FASL, "LISP INFERIOR TECO") + +(COMMENT DECLARATIONS AND SPECIALS) + +(DECLARE (SPECIAL NULL *BREAK16-FUNCTION *VALUE *BREAK CURRENT-JOB DDT-READTABLE + J*STADR J*CRUFT SEND-*VALUE-TO-DDT? JOB-STACK + JOB-INTERRUPT-LIST JOB-RING JOB-INFORM CRLF LISP-CURSORPOS + WAITING-FOR-JOB-INT THE-JOB-INPUT-CHANNEL %OPCMD %OPLSP + TTY-PASSING-MSG TTY-RETURN-LIST DEFAULT-TTY-RETURN-LIST + TTY-RETURN-MSG TTY-RETURN-PROMPT? TTY-RETURN-PROMPTER + RETURN-TO-DDT-LIST DEFAULT-RETURN-TO-DDT-LIST TTY-YANKED-FLAG + JOB-HAD-TTY? TTY-YANKED? TTY-VERBOSE JOB-MSG-FILE TTYRETFUN) + (FIXNUM I N (CALC-EFF-ADR FIXNUM)) + (*EXPR P JOB-USET-WRITE JOB-USET-READ EXAMINE-JOB DEPOSIT-JOB + KILL-JOB VALUE-STRING *ATTY *DTTY SELECT-JOB) + (*LEXPR G START :JCL SET-JCL CREATE-JOB print-console-msg)) + +(eval-when (eval compile) + (setq ibase 8) + (cond ((not (get '*uset 'macro)) + (fasload lusets fasl dsk liblsp))) + (cond ((not (status feature lspmac)) + (fasload lspmac fasl dsk liblsp))) + (defun prinj macro (x) `(princ ,(cadr x) 'job-msg-file)) + (defun terprj macro (x) '(terpri job-msg-file))) + +(if (not (getl 'create-job '(lsubr autoload))) + (defprop create-job (humble fasl dsk liblsp) autoload)) + +(special-init send-*value-to-ddt? t) + +; SET UP DEFAULT HANDLERS FOR PARTICULAR INTERRUPTS + +(SETQ *VALUE '*VALUE-HANDLER *BREAK '*BREAK-HANDLER ^ZTYPED '^Z-INTERRUPT + PIDCL 'DEFERRED-CALL LISP-CURSORPOS NIL WAITING-FOR-JOB-INT NIL + NULL (ASCII 0) JOB-STACK NIL + J*STADR (GETDDTSYM 'J/.STADR) + J*CRUFT (GETDDTSYM 'J/.CRUFT) + %OPCMD 1_40 + %OPLSP 100_18. + TTY-PASSING-MSG NIL + JOB-HAD-TTY? NIL + TTY-YANKED? T + TTY-VERBOSE T + JOB-MSG-FILE (OPEN '|TTY:| '(OUT TTY ASCII))) + +(SPECIAL-INIT *BREAK16-FUNCTION NIL) + +(SPECIAL-INIT TTY-RETURN-MSG (COND ((STATUS FEATUR MACSYMA) + '|(Console connected with MACSYMA)|) + (T '|(Console connected with LISP)|))) + +(SETQ LNULL '(NIL) JOB-RING NIL ;(RPLACD LNULL LNULL) + CRLF '|/ +|) + + +(COMMENT JOB INTERRUPT HANDLER) + +; This is the ordinary function for handling job related interrupts. +; When a job is created, this is specified as the interrupt handler, +; e.g. (CREATE-JOB JOB-INTERRUPT-HANDLER NIL) +; The basic dispatch mechanism is that the PIRQC word for the job +; causing the interrupt is decoded into a list of symbolic interrupt +; names. An arbitrator decides which of the interrupts should get +; handled in which order. The handling mechanism is by applying +; the value of the interrupt symbol (if non-nil) to the UUO word. +; The most useful one's are .VAULE and .BREAK. + +(DEFUN JOB-INTERRUPT-HANDLER (JOB) + (SETQ JOB-HAD-TTY? (NULL (STATUS TTY))) ; IF LISP DIDN'T, JOB DID + (*DTTY) + (PUSH-SELECT-JOB JOB) + (DO ((UUO (*USET *RSV40)) + (INTERRUPT-LIST (ARBITRATE-INTERRUPTS + (PIRQC-DECODE (*USET *RPIRQ) (*USET *RMASK))) + (CDR INTERRUPT-LIST)) + (INTBIT) (INTSYM)) + ((NULL INTERRUPT-LIST)) + (SETQ INTBIT (LSH 1 (CDAR INTERRUPT-LIST)) + INTSYM (CAAR INTERRUPT-LIST)) + (*USET *SAPIR INTBIT) + (COND ((BOUNDP INTSYM) (FUNCALL (SYMEVAL INTSYM) UUO)) + (T (RANDOM-CLASS1-INTERRUPT INTSYM))) + (POP-SELECT-JOB)) + (IF (AND (STATUS TTY) WAITING-FOR-JOB-INT) ; not very general... + (SETQ WAITING-FOR-JOB-INT NIL)) + NULL) + +; Arbitrator could do something useful someday + +(DEFUN ARBITRATE-INTERRUPTS (INT-LIST) INT-LIST) + +(COMMENT PIRQC DECODE) + +; Interrupt word decoder. Decodes into a list of symbols whose value +; is a routine to run. + +(DEFUN PIRQC-DECODE (PIRQC MASK) + (DECLARE (FIXNUM PIRQC)) + (PROG (L) + (RETURN + (COND ((PLUSP PIRQC) ; FIRST WORD INTERRUPTS + (DO ((PIRQC PIRQC (LSH PIRQC -1)) + (MASK (BOOLE 6 -1 MASK) (LSH MASK -1)) + (DECOD JOB-INTERRUPT-LIST (CDR DECOD)) + (I 0 (1+ I))) + ((ZEROP PIRQC) L) + (DECLARE (FIXNUM I)) + (COND ((PLUSP (BOOLE 1 1 PIRQC MASK)) + (SETQ L (CONS (CONS (CAR DECOD) I) L)))))) + (T ;2ND WORD INTS + (DO ((PIRQC PIRQC (LSH PIRQC -1)) + (I 0 (1+ I))) + ((> I 17)) + (IF (PLUSP (BOOLE 1 1 PIRQC)) + (SETQ L (CONS + (CONS (IMPLODE + (NCONC (EXPLODEN 'IOCH) (EXPLODEN (1- I)))) + I) + L)))) + (DO ((PIRQC (BOOLE 1 377777 (LSH PIRQC -18.)) (LSH PIRQC -1)) + (I 0 (1+ I))) + ((> I 7) L) + (IF (PLUSP (BOOLE 1 1 PIRQC)) + (SETQ L (CONS + (CONS (IMPLODE + (NCONC (EXPLODEN 'INF) (NCONS (+ 60 I)))) + (+ 18. I)) + L))))))))) + + +(COMMENT RANDOM INTERRUPTS (UN-HANDLED)) + +; If we don't want to bother figuring out what to do, just punt informatively + +(DEFUN RANDOM-CLASS1-INTERRUPT (INT) + (PRINJ '|INFERIOR CLASS 1 INTERRUPT - |) + (PRINJ INT) + (TERPRJ) + null) + +; If ^Z typed ... + +(DEFUN ^Z-INTERRUPT (DUMMY) (DECLARE (FIXNUM DUMMY)) + (SETQ DUMMY DUMMY) + (DO NIL ((ZEROP (LISTEN T))) (TYI))) ; GOBBLE TYPE-AHEAD + + +(DEFUN DEFERRED-CALL (DUMMY) (SETQ DUMMY DUMMY)) + +(DEFUN CALC-EFF-ADR (ADR) + (DECLARE (FIXNUM ADR)) + ((LAMBDA (@ X Y) (DECLARE (FIXNUM @ X Y)) + (OR (ZEROP X) + (SETQ Y (BOOLE 1 777777 + (+ Y (EXAMINE-JOB X))))) + (COND ((ZEROP @) Y) + (T (CALC-EFF-ADR (EXAMINE-JOB Y))))) + (BOOLE 1 ADR 20_22) + (BOOLE 1 17 (LSH ADR -22)) + (BOOLE 1 777777 ADR))); .VALUE Handler. + +(COMMENT *VALUE HANDLER) + +(DEFUN *VALUE-HANDLER (UUO) + (COND ((ZEROP (BOOLE 1 777777 UUO)) (*VALUE0)) + (T (*VALUE-STRING (GET-STRING (BOOLE 1 777777 UUO)))))) + +; A simple return with no information. (SHOULD TELL WHICH JOB!!) + +(DEFUN *VALUE0 NIL (PRINC0 '|.VALUE 0.| job-msg-file) (TERPRI job-msg-file) NULL) + +; A return with a request for action in the form of a string. (SHOULD BE IMPROVED) + +(DEFUN *VALUE-STRING (VST) + (COND ((EQUAL VST '|:PROCED |) (CONTINUE-JOB NIL)) + ((EQUAL VST '|:KILL |) (PRINJ '|:KILL |) (KILL-JOB)) + ((= 33 (GETCHARN VST 1)) (EVAL (READLIST (CDR (EXPLODEN VST))))) + (SEND-*VALUE-TO-DDT? + (COND ((NOT (EQ T SEND-*VALUE-TO-DDT?)) + (PRINJ '|Inferior .VALUE = "|) (PRINJ VST) + (PRINJ '| "|) (TERPRJ) (PRINJ '|Feed commands to DDT?: |) + (COND ((NOT (MEMQ (let ((READTABLE + (ARRAY NIL READTABLE))) + (SETSYNTAX 15 500500 15) + (READ)) + '(Y YES T))) + (SETQ VST NIL))))) + (COND (VST (setq tty-return-prompt? nil) + (nointerrupt nil) + (let ((tty-return)) (VALRET VST)))) + (CONTINUE-JOB JOB-HAD-TTY?)) + (T (PRINC0 '|; Inferior .VALUE ignored.|) (TERPRI) + (CONTINUE-JOB JOB-HAD-TTY?)))) + + +; Get a string from the memory of the current job as an exploded list + +(DEFUN GET-STRING (LOC) (MAKNAM (VALUE-STRING LOC))) ; REWRITE USING EXAMINE-JOB + +(DEFUN VALUE-STRING (ADR) + ((LAMBDA (FILE) + (FILEPOS FILE (* ADR 5)) + (DO ((C (TYI FILE) (TYI FILE)) + (L NIL (CONS C L))) + ((ZEROP C) (CLOSE FILE) (NREVERSE L)) + (DECLARE (FIXNUM C)))) + (OPEN CURRENT-JOB '(IN BLOCK ASCII)))) + +(COMMENT JOB CONTROL FUNCTIONS) + +; Deposit JCL in the job. +(DEFUN PUT-JCL (LOC JCL) + (IF (AND JCL (NOT (ATOM JCL))) (SETQ JCL (MAKNAM (MAPCAN 'EXPLODEC JCL)))) + (IF JCL + (DO ((I LOC (1+ I)) (L (PNGET JCL 7) (CDR L))) + ((NULL L) (DEPOSIT-JOB I 0)) + (DEPOSIT-JOB I (CAR L))))) + +(DEFUN SET-JCL N + (IF (NULL CURRENT-JOB) (ERROR '|No job - :JCL |)) + (*USET *SOPTI (BOOLE 7 %opcmd (*USET *ROPTI))) + (PROGB ((JCRUFT (MUNKAM (ARRAYCALL FIXNUM CURRENT-JOB J*CRUFT)))) + (COND ((NULL JCRUFT) + (SETQ JCRUFT (LIST NIL)) + (STORE (ARRAYCALL FIXNUM CURRENT-JOB J*CRUFT) + (MAKNUM JCRUFT)))) + (PUTPROP JCRUFT (LISTIFY N) 'JCL)) + T) + +(DEFUN START-JOB (LOC ATTYP) + (DECLARE (FIXNUM LOC)) + (IF (NULL CURRENT-JOB) (ERROR '|No job - START-JOB|)) + (IF (NOT (ZEROP LOC)) (STORE (ARRAYCALL FIXNUM CURRENT-JOB J*STADR) + (+ 254_33 (BOOLE 1 777777 LOC)))) + (SETQ LOC (JOB-START-ADR CURRENT-JOB)) + (IF (ZEROP LOC) (ERROR '|No start address? |)) + (*USET *SUPC LOC) + (CONTINUE-JOB ATTYP)) + +(DEFUN JOB-START-ADR (JOB) + (IF (NOT (EQ CURRENT-JOB JOB)) (SELECT-JOB JOB)) + (BOOLE 1 777777 (ARRAYCALL FIXNUM CURRENT-JOB J*STADR))) + +(DEFUN SET-JOB-START-ADR (JOB ADDR) + (STORE (ARRAYCALL FIXNUM JOB J*STADR) (BOOLE 1 777777 ADDR))) + +(DEFUN CONTINUE-JOB (ATTYP) + (IF (NULL CURRENT-JOB) (ERROR '|No job - CONTINUE-JOB |)) + (IF ATTYP + (PROGN (COND (TTY-PASSING-MSG + (print-console-msg TTY-PASSING-MSG) + (CURSORPOS 'E))) + (SETQ LISP-CURSORPOS (CURSORPOS) + TTY-PASSING-MSG NIL + TTY-YANKED? NIL))) + (*USET *SPIRQ 0) + (IF (= 0 (BOOLE 1 777777 (*USET *RUPC))) + (*USET *SUPC (JOB-START-ADR CURRENT-JOB))) + (nointerrupt 'T) + (*USET *SUSTP 0) + (SLEEP .001) + (cond (attyp (%tbnot-off) (*atty))) + (NOINTERRUPT NIL) + NULL) + +(DEFUN WAIT-FOR-JOB (JOB) ; WAITS UNTIL JOB HAS STOPPED + (NOINTERRUPT NIL) + (DO ((CURRENT-JOB JOB)) + ((NOT (ZEROP (*USET *RUSTP)))) + (WAIT-FOR-JOB-INT JOB)) + (*DTTY) T) + +(DEFUN MAKE-JOB (JNAME) + (let ((^W T)) + (CREATE-JOB 'JOB-INTERRUPT-HANDLER 'CHANNEL-INT-HANDLER + JNAME (STATUS UNAME)))) + +(DEFUN DISOWN-JOB (JOB) + (IF (NOT (EQ CURRENT-JOB JOB)) (SELECT-JOB JOB)) + (IF (AND WAITING-FOR-JOB-INT (EQ JOB WAITING-FOR-JOB-INT)) + (SETQ WAITING-FOR-JOB-INT NIL)) + (*USET *SPIRQ 0) + (*USET *SOPTI (BOOLE 2 %OPLSP (*USET *ROPTI))) + (PROG2 NIL (NULL (SYSCALL 0 'DISOWN THE-JOB-INPUT-CHANNEL)) + (KILL-JOB))) ; flush the job + + +; generally useful DDT commands + +(DEFUN :CONTIN NIL (CONTINUE-JOB T) NULL) + +(DEFUN P NIL (TERPRI) (:CONTIN)) + +(DEFUN :START N (START-JOB (COND ((ZEROP N) 0) (T (ARG 1))) T) NULL) + +(DEFUN G N (TERPRI) (APPLY '/:START (LISTIFY N))) + +(DEFUN :DISOWN NIL (DISOWN-JOB CURRENT-JOB)) + +(COMMENT +; DDT LIKE COMMANDS + +(ARRAY DDT-READTABLE READTABLE) +(SETQ DDT-READTABLE (GET 'DDT-READTABLE 'ARRAY)) +(let ((READTABLE DDT-READTABLE)) + (SETSYNTAX '/ 'MACRO 'DDT-ALTMODE-MACRO) + (SETSYNTAX '/: 'MACRO 'DDT-COLON-MACRO) + (SETSYNTAX 15 601540 15) + (SSTATUS TTYREAD NIL)) + + +(DEFUN DDT () (DO ((READTABLE DDT-READTABLE)) (NIL) (PRINT (EVAL (READ))))) + +(DEFUN DDT-ALTMODE-MACRO (X) X) ; USE PRE SCAN?? +(DEFUN DDT-COLON-MACRO (X) X) + +(DEFUN :JCL N (APPLY 'SET-JCL (LISTIFY N))) + +(DEFUN :PROCEED NIL (CONTINUE-JOB NIL) '*) + +(DEFUN ^P NIL (TERPRI) (:PROCEED)) + +(DEFUN :GZP NIL (START-JOB 0 T) '*) + +(DEFUN J N + (COND ((= 0 N) + (COND (JOB-RING (SETQ JOB-RING (CDR JOB-RING)) + (SELECT-JOB (CAR JOB-RING)) (CAR JOB-RING)))) + (T (COND ((MEMQ (ARG 1) JOB-RING) + (DO NIL ((EQ (ARG 1) (CAR JOB-RING))) + (SETQ JOB-RING (CDR JOB-RING))) + (SELECT-JOB (CAR JOB-RING)) (CAR JOB-RING)) + (T (SET (ARG 1) + (CADR (CREATE-JOB 'JOB-INTERRUPT-HANDLER + 'JOB-CHANNEL-HANDLER + (ARG 1) + (STATUS USERID)))) + (SETQ JOB-RING + (CDR (RPLACD JOB-RING + (CONS CURRENT-JOB (CDR JOB-RING)))))))))) + +(DEFUN J FEXPR (X) (SET (CAR X) (CAR JOB-RING))) + +) ; END OF COMMENTED OUT CODE + +(DEFUN *BREAK-HANDLER (UUO) + (DECLARE (FIXNUM AC EFF UUO)) + (PROG (AC EFF) + (SETQ AC (BOOLE 1 17 (LSH UUO -23.)) EFF (BOOLE 1 777777 UUO)) + (COND ((= AC 16) (*BREAK16-HANDLER EFF)) + ((= AC 12) (*BREAK12-HANDLER EFF)) + (T (PRINJ '|ILOPR. |) (PRINJ (BOOLE 1 777777 (*USET *RUPC))) + (PRINJ '|>>.BREAK |) (PRINJ AC) (PRINJ '/,) (PRINJ EFF) (TERPRJ))))) + +(DEFUN *BREAK16-HANDLER (EFF) + (COND ((PLUSP (BOOLE 1 100000 EFF)) + (COND (*BREAK16-FUNCTION (APPLY *BREAK16-FUNCTION (LIST EFF))))) + ((PLUSP (BOOLE 1 40000 EFF)) + (PRINJ '|:KILL |) (KILL-JOB) CRLF) + ((PLUSP (BOOLE 1 24000 EFF)) (KILL-JOB) CRLF) + (T (PRINJ '|ILOPR. |) (PRINJ (BOOLE 1 777777 (*USET *RUPC))) + (PRINJ '|>>.BREAK 16,|) (PRINJ EFF) (TERPRJ) CRLF))) + + +(DEFUN *BREAK12-HANDLER (EFF) + (LET ((TTY-RETURN '(LAMBDA (X) NIL))) + (NOINTERRUPT NIL) ; let tty-return lose + (DO ((CEFF (EXAMINE-JOB EFF)) (TYPE 0)) NIL (DECLARE (FIXNUM CEFF TYPE)) + (COND ((= 6 (LSH CEFF -41)) + (DO ((I (1+ (BOOLE 6 777777 (LSH CEFF -22))) (1- I)) + (LOC (BOOLE 1 777777 CEFF) (1+ LOC))) + ((ZEROP I)) + (*BREAK12-HANDLER (EXAMINE-JOB LOC)))) + ((MINUSP CEFF) + (SETQ TYPE (LSH (BOOLE 6 -4_41 CEFF) -22) + CEFF (BOOLE 1 777777 CEFF)) + (COND ((= TYPE 1) + (STORE (ARRAYCALL FIXNUM CURRENT-JOB J*STADR) + (+ 254_33 (BOOLE 1 777777 (EXAMINE-JOB CEFF)))) + (CONTINUE-JOB JOB-HAD-TTY?)) + ((= TYPE 3) (CONTINUE-JOB JOB-HAD-TTY?)) ;SYMBOLS + ((= TYPE 4) (CONTINUE-JOB JOB-HAD-TTY?)) ;SYMBOLS + ((= TYPE 5) + (PUTPROP (MUNKAM (ARRAYCALL FIXNUM CURRENT-JOB + J*CRUFT)) + NIL + 'JCL) ; CLEAR JCL + (CONTINUE-JOB JOB-HAD-TTY?)) + ((= TYPE 6) (CONTINUE-JOB JOB-HAD-TTY?)) ; SET DFILE + ((= TYPE 7) (CONTINUE-JOB JOB-HAD-TTY?)) ; SYMBOL HACKING + (T (PRINJ '|ILOPR. |) (PRINJ (BOOLE 1 777777 (*USET *RUPC))) + (PRINJ '|>>.BREAK 12,|) (PRINJ EFF) (TERPRJ) CRLF))) + (T (SETQ TYPE (LSH CEFF -22) + CEFF (BOOLE 1 777777 CEFF)) + (COND ((= TYPE 1) + (DEPOSIT-JOB CEFF (ARRAYCALL FIXNUM CURRENT-JOB J*STADR))) + ((= TYPE 2) (CONTINUE-JOB JOB-HAD-TTY?)) + ((= TYPE 3) + (DEPOSIT-JOB CEFF 0) + (CONTINUE-JOB JOB-HAD-TTY?)) ; SYMBOLS + ((= TYPE 4) + (DEPOSIT-JOB CEFF 0) + (CONTINUE-JOB JOB-HAD-TTY?)) ; SYMBOLS + ((= TYPE 5) + (PUT-JCL CEFF + (GET (MUNKAM (ARRAYCALL FIXNUM CURRENT-JOB + J*CRUFT)) + 'JCL)) + (CONTINUE-JOB JOB-HAD-TTY?)) + ((= TYPE 6) (CONTINUE-JOB T)) + ((= TYPE 7) + (DEPOSIT-JOB CEFF 0) + (CONTINUE-JOB JOB-HAD-TTY?)) + ((= TYPE 10) + (DEPOSIT-JOB (1+ CEFF) (EXAMINE-JOB CEFF)) + (DEPOSIT-JOB CEFF 0) + (CONTINUE-JOB JOB-HAD-TTY?)) + (T (PRINJ '|ILOPR. |) (PRINJ (BOOLE 1 777777 (*USET *RUPC))) + (PRINJ '|>>.BREAK 12,|) (PRINJ EFF) (TERPRJ) (SLEEP 60) + (CONTINUE-JOB JOB-HAD-TTY?)))))))) + +(COMMENT TTY Return Functions) + +(special-init default-tty-return-list '((default-tty-return ttyretarg))) + +(setq tty-return 'tty-return-handler + tty-return-list default-tty-return-list + tty-yanked-flag T) + +(defun tty-return-handler (ttyretarg) (declare (special ttyretarg)) + (let ((tty-yanked-flag tty-yanked?)) + (setq tty-yanked? T) + (mapc 'eval tty-return-list) + (setq tty-return-list default-tty-return-list))) + +(defun default-tty-return (x) + (cond ((and (or (status feature MACSYMA) (= 0 (listen tyi))) + (null tty-yanked-flag)) + (cursorpos 'C job-msg-file) + (funcall (if (status feature MACSYMA) 'print-console-msg 'princt) + (if tty-return-msg tty-return-msg + (if (status feature MACSYMA) '|(MACSYMA)| + '|(LISP)|)) + job-msg-file))) + (force-output job-msg-file) + (if tty-return-prompt? (funcall tty-return-prompter x)) + (setq tty-return-prompt? t) + T) + +(defun princt n + (progb ((args (listify n))) + (apply 'princ args) + (apply 'terpri (cdr args)))) + +(defun clear-tty-return nil + (let ((tty-return '(lambda(x) x))) (declare (special tty-return)) + (nointerrupt nil)) + (setq tty-return-prompt? T + tty-return-list default-tty-return-list)) + +(special-init tty-return-prompt? t) + +(special-init tty-return-prompter + (cond ((status feature MACSYMA) 'ttyretfun) + (t 'lisp-prompt))) + +(defun lisp-prompt (x) (if (eq 'IN x) (progn (princ0 '*) (terpri)))) + +(special-init default-return-to-ddt-list '((ddt-return))) + +(setq return-to-ddt-list default-return-to-ddt-list) + +(defun return-to-ddt nil + (mapc 'eval return-to-ddt-list) + (setq return-to-ddt-list default-return-to-ddt-list)) + +(defun ddt-return nil + (CURSORPOS 'A) + (funcall (if (status feature MACSYMA) 'print-console-msg 'PRINCT) + (if tty-passing-msg tty-passing-msg '|(DDT)|)) + (cursorpos 'E) + (setq tty-passing-msg nil tty-yanked? NIL) + (ddt-exit)) + +(defun ^Z-char-interrupt (file ch) (setq ch ch) + (if (not (= 0 (listen file))) (tyi file)) + (return-to-ddt)) + +(sstatus ttyint 32 '^Z-char-interrupt) +(sstatus ttyint 25 '^Z-char-interrupt) + +(defun print-console-msg nargs + (let ((msg (arg 1)) + (job-msg-file (cond ((< nargs 2) job-msg-file) + (T (arg 2))))) + (cond ((and tty-verbose (memq 'CURSORPOS (status filemode job-msg-file)) + (STATUS FEATURE MACSYMA)) + (if (not (= 0 (cdr (cursorpos)))) (terpri job-msg-file)) + (CURSORPOS 'L) + (CURSORPOS 'H (1- (// (- (LINEL JOB-MSG-FILE) (flatc msg)) 2))))) + (cond (tty-verbose + (princ msg job-msg-file) + (terpri))) + T)) + +(DEFUN PUSH-SELECT-JOB (JOB) + (SETQ JOB-STACK (CONS CURRENT-JOB JOB-STACK)) + (SELECT-JOB JOB)) + +(DEFUN POP-SELECT-JOB NIL + (DO NIL + ((NULL JOB-STACK)) + (IF (JOBP (CAR JOB-STACK)) ; FILTER DEAD JOBS + (RETURN (SELECT-JOB (CAR JOB-STACK)))) + (IF (EQ (CAR JOB-STACK) WAITING-FOR-JOB-INT) + (SETQ WAITING-FOR-JOB-INT NIL)) + (SETQ JOB-STACK (CDR JOB-STACK)))) + + +; LIST OF PARTICULAR INTERRUPT HANDLERS + +(SETQ JOB-INTERRUPT-LIST + '(TYPEIN + ^ZTYPED + BADPI + AROV + 340DPY + ILOPR + SYSDED + *VALUE + IOC + ILUAD + *BREAK + 1PROC + SLOWCLOCK + MPV + MAR + LTPEN + PDLOV + CLI + RESTR + SYSDBG + ARMTP1 + ARMTP2 + ARMTP3 + SYSUUO + PURINS + PURPG + ARFOV + PARERR + PITTY + PIATY ; JOB GOT TTY BACK + PIDCL ; DELAYED CALL + <4/.5> + <4/.6> + RUNTIM + REALTM + )) + +(Comment Functions to interface with ITS) + +(OR (GETDDTSYM T) + ((LAMBDA (TTY-RETURN) (VALRET '|/î:SL /î:VP |)) NIL)) + +(lap %TBNOT-OFF subr) + (movei t tt) + (hrli t 2) ; .RTTY + (*suset 0 t) ; read it + (tlz tt 4000) ; clear %tbout + (tlo t 400000) ; make into .STTY + (*suset 0 t) ; set it + (movei 1 't) ; return T + (popj p) +() + +;; takes a job object and waits for an interrupt on that job +(lap wait-for-job-int subr) + (args wait-for-job-int (nil . 1)) + (movem a (special waiting-for-job-int)) + (movei a (special waiting-for-job-int)) + (skipe 0 0 a) + (*hang 0) + (movei A 'T) + (popj p) +() + +(lap jobp subr) ; is it a valid job object (and open) +(args jobp (nil . 1)) + (move t 1 (a)) + (movei a nil) + (tlnn t 'tts/.cl) + (movei a 'truth) + (popj p) +() + +(lap ddt-exit subr) + (*break 16 300000) ; return with a kerchink + (movei A 'truth) + (popj p) +() diff --git a/src/libdoc/ndone.rvb1 b/src/libdoc/ndone.ejs2 old mode 100755 new mode 100644 similarity index 70% rename from src/libdoc/ndone.rvb1 rename to src/libdoc/ndone.ejs2 index f0729f3c..09e10439 --- a/src/libdoc/ndone.rvb1 +++ b/src/libdoc/ndone.ejs2 @@ -19,27 +19,27 @@ (SKIPA) (ENTRY COMPLR-ERROR SUBR) (ARGS COMPLR-ERROR (NIL . 0)) - (MOVE A,(SPECIAL COMPLR-ERROR-MESSAGE)) + (MOVE A (SPECIAL COMPLR-ERROR-MESSAGE)) (SKIPA) (ENTRY COMPLR-DONE SUBR) (ARGS COMPLR-DONE (NIL . 0)) - (MOVE A,(SPECIAL COMPLR-DONE-MESSAGE)) + (MOVE A (SPECIAL COMPLR-DONE-MESSAGE)) - (*IOPUSH 15,) ;GUARANTEE A FREE CHANNEL - (*SUSET 0,MYUNAME) - (*OPEN 15,HCTRN-BLOCK) - (JRST 0,DIE) + (*IOPUSH 15) ;GUARANTEE A FREE CHANNEL + (*SUSET 0 MYUNAME) + (*OPEN 15 HCTRN-BLOCK) + (JRST 0 DIE) - (MOVE R,(% SETZ 0,CHROUT));A & R SETUP FOR - (PUSHJ P,PRINTA) ; PRINTA THAT FOLLOWS - (*CLOSE 15,) -DIE (*IOPOP 15,) - (MOVEI A,'T) - (POPJ P,) + (MOVE R (% SETZ 0 CHROUT));A & R SETUP FOR + (PUSHJ P PRINTA) ; PRINTA THAT FOLLOWS + (*CLOSE 15) +DIE (*IOPOP 15) + (MOVEI A 'T) + (POPJ P) ;;; OUTPUT CHARACTER IN A -CHROUT (*IOT 15,A) - (POPJ P,) ;PRINTA CALLING CONVENTIONS +CHROUT (*IOT 15 A) + (POPJ P) ;PRINTA CALLING CONVENTIONS MYUNAME (0 0 USLOT 4) ;I.E. ?,,USLOT HCTRN-BLOCK diff --git a/src/libdoc/prime.pratt1 b/src/libdoc/prime.ejs2 old mode 100755 new mode 100644 similarity index 75% rename from src/libdoc/prime.pratt1 rename to src/libdoc/prime.ejs2 index 1add3ff1..b29eb25c --- a/src/libdoc/prime.pratt1 +++ b/src/libdoc/prime.ejs2 @@ -6,8 +6,9 @@ prime_error_rate proportion of uses, assuming the random number generator has no unfortunate properties. A composite may be mistaken for a prime, but not vice versa. % -export prime, witness_count, rab$ % The only symbols users - of the package may access % +% commented out by ejs: 2018-10-01 since it appears to not work % +% export prime, witness_count, rab $ % +% The only symbols users of the package may access % special n, n_1, witness_count, w, sw $ @@ -32,15 +33,15 @@ define rab(a,j); % careful exponentiation - % 'rbp' of 'prime' := 10 $ -define prime(n); % Returns T if n is prime % -if n<30 then if n isin !'(2 3 5 7 11 13 17 19 23 29) then t else nil -else - gcd(n,6469693230) = 1 +define "PRIME"(n); % Returns T if n is prime % + if n<30 then if n isin !'(2 3 5 7 11 13 17 19 23 29) then t else nil + else + gcd(n,6469693230) = 1 and - let n_1 = n-1; - iter for k := 1 step k+1 + let n_1 = n-1; + iter for k := 1 step k+1 for looks_prime := (rab(witness(),n_1) = 1) step ditto while looks_prime and k|) ;;my macros etc. + +(defcomment rdtags) ;;for emacs tags + +;;this file reads emacs tags created by :tags and creates a file of +;;defprop of the function names in the tags file to an autoload-property +;;those defining functions (such as defun) without an autoload-porperty are ignored +;;there is only one known very obscure screw, that occurs only if the function +;;name in the lisp file is immediately followed by a carriage return (before argument-list) +;;and the function name ends in a number then the function name without the number is defproped +;;Currently it skips any files in your tags file whose language is not LISP + + +;;TO USE THIS: first define which kinds of defining forms you want autoloaded (and how) +;;by putting on the defining function a property indicating what property you want for the +;;symbol being defined to have. + +;;FOR EXAMPLE: +;;(defprop defun autoload autoload-property) this is typical +;;(defprop define-macro macro-load autoload-property) where you'll make use of macro-load + +;;THEN: just call the function "read-eamcs-tags" with the name of your tags file +;;and the name of the output file you want. Optionally you can restrict the program to +;;consider only functions defined in a list of file names you provide + +;;FOR EXAMPLE: + +;;(read-emacs-tags '|foo;foo tags| '|foo;foo ltags| '(file1 |bar;file1| file2)) + +;;reading foo's tags and making a file of autoload of foo's file1 and file2 and bar's file1 +;;the file "foo;foo ltags" should look something like +;;(defprop function1 foo/;file1 autoload) +;;(defprop macro24 foo/;file1 macro-load) +;;(defprop function2 bar;file1 autoload) +;;and so on + +;;ADVICE: +;;If you are concerned that putting an autoload property on all your functions wastes too +;;much memory you can do two things: +;;(a) Make your version of "defun" be a macro that remprop's the symbol's autoload property +;;(b) Have two names for defun: one of which will generate autoload properties +;; and the other you use only for internal functions. + +(declare (special output-file input-file)) ;;for debugging + +;; define-function is almost the same as "defun" but it remprops its 'autoload property + +(define-function read-emacs-tags (tags-file-name ltags-file-name &optional (only-these-files)) + ;;if only-these-files is nil read all files otherwise only those in only-these-files are read + (let-files ;;closes files nicely and closes for errors + ((input-file (open tags-file-name 'in)) + (output-file (open ltags-file-name 'out))) + (let + ((only-these-files + (and only-these-files + (mapcar + (function (lambda (file-name) + (mergef '((dsk *) * *) + (mergef file-name '((dsk ,(second (crunit))) * >))))) + only-these-files)))) + (catch + (do ((file-name) + (next-char (tyipeek-eof input-file) (tyipeek-eof input-file))) + ((= next-char 3)) ;;control-c + (cond ((or (and (not (member (setq file-name (read-tags-file-name input-file)) + only-these-files)) + only-these-files) + (not (eq (read-language-name input-file) 'lisp))) ;;only lisp files + (skip-rest-of-file input-file)) + (t (read-defun-lines (autoload-name file-name) input-file)))) + end-of-file)))) + +(defun autoload-name (file-name) + (maknam (append (exploden (second (first file-name))) ;;directory + '(#/;) + (exploden (second file-name))))) + +(defun read-tags-file-name (input-file) + (mergef '((dsk *) * *) + (readline input-file))) + +(defun read-language-name (input-file) + (read input-file) ;; the file length or something + (tyi input-file) ;;gobble up the , + (read input-file)) ;;the name + +(defun read-defun-lines (file-name input-file) + (let ((first-letter (tyi -1 input-file))) + (cond ((= first-letter #(getcharn '|(| 1)) + (let ((autoload-property (get (read input-file) 'autoload-property))) + (cond ((null autoload-property) (read-to-cr input-file)) ;;skip this one + (t (flush-spaces input-file) + (cond ((= (tyipeek -1 input-file) #(getcharn '|(| 1)) + ;;as in (defun (foo bar) ...) + (tyi -1 input-file))) ;;gobble it up + (let* ((function-name (read input-file -1)) + (next-letter (cond ((and (numberp function-name) + (= function-name -1)) -1) + (t (tyipeek -1 input-file))))) + (cond ((= next-letter -1) ;;eof + (throw t end-of-file)) + ((or (= next-letter #(getcharn '|(| 1)) + (= next-letter #(getcharn '|| 1))) + ;;if the is no space after function name as when + ;;a ctrl-m is there which happens + ;;if defun has carriage after function name + (setq function-name (fix-function-name function-name))) + (t (read-to-cr input-file))) ;ignore position number + (print + '(defprop ,function-name ,file-name ,autoload-property) + output-file))))) + (read-defun-lines file-name input-file)) + ((= first-letter #(getcharn '|| 1)) + (tyi -1 input-file) (tyi -1 input-file)) ;eat up + ((= first-letter 10.) ;; + (read-defun-lines file-name input-file)) ;;try again + ((= first-letter 13) ;; + (read-defun-lines file-name input-file)) + (t (print '(,(ascii first-letter) | first letter is not right|)) + (break bad-tags-file? t))))) + +;;this removes the right-most numbers from an atom +;;since there will be crud there if one had a cr after function name eg +;;(defun foo +;; (x) ...) + +(defun fix-function-name (function-name) + (do ((letters (nreverse (exploden function-name)) (rest letters))) + ((null letters) function-name) + (let ((letter (first letters))) + (cond ((and (> letter 47) (< letter 58))) + (t (return (implode (nreverse letters)))))))) + +(defun read-to-cr (input-file) + (read-ending-with #(getcharn '/ + 1) input-file)) + +(defun skip-rest-of-file (input-file) + (throw-away-until #(getcharn '|| 1) input-file) + (tyi input-file) (tyi input-file)) + +(declare (fixnum character)) + +(defun throw-away-until (stop-character input-file) + (do ((character (tyi -1 input-file) (tyi -1 input-file))) + ((= character stop-character)) ;;get rid of the rest + (cond ((= character -1) (throw t end-of-file))))) + +(defun read-ending-with (end-character input-file) + ;;this returns the list of characters in the reverse order read + (do ((character-list nil (cons character character-list)) + (character 0.)) + ((= (setq character (tyi -1 input-file)) end-character) + (cons end-character character-list)))) + +(defun flush-spaces (input-file) + (do ((character (tyipeek -1 input-file) + (progn (tyi -1 input-file) (tyipeek -1 input-file)))) + ((not (= character 32.))))) + +(defun tyipeek-eof (input-file) + (let ((tyipeek-result (tyipeek -1. input-file))) + (cond ((minusp tyipeek-result) (throw t end-of-file)) + (tyipeek-result)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Create @ xfile from tags file +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;;The function @-emacs-tags creates an @ xfile from a tags file, writing +;;; it out with second filename "XFILE". This file can be editted, if +;;; desired, and then executed by typing ":XFILE fn1 XFILE" to DDT. +;;; +(define-function /@-emacs-tags (tags-file-name &optional (xgp? t) (only-these-files)) + ;;if only-these-files is nil read all files otherwise only those in only-these-files are read +(let ((/@-xfile-name (mergef '((* *) * xfile) tags-file-name)) + (/@-lrec-file-name (mergef '((* *) * lrec) tags-file-name)) + (tags-file-name (mergef '((* *) * tags) tags-file-name))) + (let-files ;;closes files nicely and closes for errors + ((input-file (open tags-file-name 'in)) + (output-file (open /@-xfile-name 'out))) + (write-/@-leader /@-lrec-file-name output-file) + (let + ((only-these-files + (and only-these-files + (mapcar + (function (lambda (file-name) + (mergef '((dsk *) * *) + (mergef file-name + (list (list 'dsk (cadr (crunit))) + '* '>))))) + only-these-files)))) + (catch + (do ((file-name) (language-name) + (next-char (tyipeek-eof input-file) (tyipeek-eof input-file))) + ((= next-char 3)) ;;control-c + (setq file-name (read-tags-file-name input-file)) + (cond + ((or (null only-these-files) (member file-name only-these-files)) + (setq language-name (read-language-name input-file)) + (cond + ((memq language-name '(lisp macsym midas r)) + (write-/@-command file-name language-name output-file xgp?))))) + (skip-rest-of-file input-file)) + end-of-file))))) + +(defun write-/@-leader (/@-lrec-file-name output-file) + (princ '|:@ | output-file) + (princ (namestring /@-lrec-file-name) output-file) + (or (probef /@-lrec-file-name) (princ '|//G| output-file))) + +(defun write-/@-command (file-name language-name output-file xgp?) + (let ((terpri t)) + (princ '|/,| output-file) + (princ (namestring file-name) output-file) + (princ '|//L[| output-file) + (princ language-name output-file) + (princ '|]| output-file) + (and xgp? (princ '|//F[20FG]| output-file)))) diff --git a/src/libdoc/step.rich12 b/src/libdoc/step.ejs13 similarity index 98% rename from src/libdoc/step.rich12 rename to src/libdoc/step.ejs13 index 8a8fc353..ac12b859 100644 --- a/src/libdoc/step.rich12 +++ b/src/libdoc/step.ejs13 @@ -20,6 +20,9 @@ ;;; (STEP FOO1 FOO2 ...) (FOO1 FOO2) ;;; +(eval-when (compile) + (setsyntax '/# 'macro nil)) + (declare (special evalhook evalhook* evalhook# prinlevel prinlength) (fixnum i n indent cmd) (macros nil)) diff --git a/src/libdoc/utils.ejs2 b/src/libdoc/utils.ejs2 new file mode 100644 index 00000000..a376b875 --- /dev/null +++ b/src/libdoc/utils.ejs2 @@ -0,0 +1,22 @@ +(cgol)$ + +% The following utility routines are of general interest. % + +define lexpr cat(n); % concatenates arguments; e.g. (CAT 'AB 'XY) -> ABXY % + implode append{explodec[arg[1 to n]]} $ + +define mod(a,b); % (MOD A B) is in the range 0 to b-1 even when a < 0 % + let x := a rem b; if minusp a ne minusp b and not zerop x then x+b else x $ + +define to(aa, b, c); % (TO 5 19 3) = (5 8 11 14 17) % + aa <= b and new x; x := [aa] & while b>=aa:=aa+c do x := cdr(cdr x := [aa]) $ + +define circ(x); x & cdr last x := x $ + +special ?&stopwatch$ % used by following timing routine % + +define timer(); % (TIMER) = CPU time in seconds since last invoked % + -?&stopwatch + ?&stopwatch := runtime()/1000000 $ + +=exit$ +