(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "20-May-88 15:18:10" {ERIS}<VANMELLE>LISP>PRETTYFILEINDEX.;46 76622
changes to%: (FNS MULTIFILEINDEX PFI.PRINT.MULTI.INDEX PRETTYFILEINDEX MULTIFILEINDEX1 PFI.CHOOSE.BEST PFI.MAKE.LPT.STREAM PFI.PRINT.INDEX PFI.PRINT.INDICES PFI.MERGE.INDICES PFI.AFTER.NEW.PAGE PFI.COMPUTE.INDEX.SHAPE)
(VARS PRETTYFILEINDEXCOMS)
previous date%: "23-Apr-88 16:54:48" {ERIS}<VANMELLE>LISP>PRETTYFILEINDEX.;36)
(* "
Copyright (c) 1988 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT PRETTYFILEINDEXCOMS)
(RPAQQ PRETTYFILEINDEXCOMS ((COMS (* ;; "Variation on SINGLEFILEINDEX that prettyprints straight to the image stream.") (FNS PFI.NEW.LISTFILES1 PFI.ENQUEUE \PFI.DO.HARDCOPY MAYBE.PRETTYFILEINDEX) (FNS PRETTYFILEINDEX PFI.MAKE.LPT.STREAM PFI.SETUP.TRANSLATIONS PFI.OUTCHARFN PFI.COLLECT.DEFINERS PFI.AFTER.NEW.PAGE) (FNS PFI.PRINT.FILECREATED PFI.PRINT.TO.TAB PFI.PRINT.ENVIRONMENT) (FNS PFI.PROCESS.FILE PFI.PASS.COMMENT PFI.HANDLE.EXPR PFI.DEFAULT.HANDLER PFI.PRETTYPRINT PFI.LINES.REMAINING PFI.MAYBE.NEW.PAGE PFI.ESTIMATE.SIZE PFI.ESTIMATE.SIZE1)) (COMS (* ; "Expression handlers") (FNS PFI.HANDLE.RPAQQ PFI.HANDLE.DECLARE PFI.HANDLE.EVAL-WHEN PFI.HANDLE.DEFDEFINER PFI.HANDLE.DEFINEQ PFI.PRINT.LAMBDA PFI.PRINT.LAMBDA.BODY PFI.HANDLE.PUTDEF PFI.HANDLE.PUTPROPS PFI.HANDLE./DECLAREDATATYPE PFI.HANDLE.* PFI.PRINT.COMMENTS PFI.HANDLE.FILEMAP PFI.HANDLE.PACKAGE)) (COMS (* ; "Previewers") (FNS PFI.PREVIEW.DECLARE PFI.PREVIEW.DEFINEQ)) (COMS (* ; "Printing the index") (FNS PFI.PRINT.INDEX PFI.CONDENSE.INDEX PFI.SORT.INDICES PFI.COMPUTE.INDEX.SHAPE PFI.PRINT.INDICES PFI.CENTER.PRINT PFI.INDEX.BREAK PFI.LOOKUP.NAME) (FNS PFI.ADD.TO.INDEX PFI.VARNAME PFI.CONSTANTNAMES)) (COMS (* ; "Combined listings") (FNS MULTIFILEINDEX MULTIFILEINDEX1 PFI.PRINT.MULTI.INDEX PFI.CHOOSE.BEST PFI.MERGE.INDICES)) (COMS (* ; "Hooks for seeing files pretty elsewhere") (FNS PFI.MAYBE.SEE.PRETTY PFI.MAYBE.PP.DEFINITION) (INITVARS (*PRINT-PRETTY-FROM-FILES* T))) (COMS (* ; "Bitmap hack") (FNS PFI.PRINT.BITMAP) (INITVARS (*PRINT-PRETTY-BITMAPS* T))) (INITVARS (*PFI-PRINTOPTIONS* (QUOTE (REGION (2540 1905 17780 24765)))) (*PFI-DONT-SPAWN*) (*PFI-MAX-WASTED-LINES* 12) (*PFI-CHARACTER-TRANSLATIONS* (QUOTE ((INTERPRESS (95 172) (96 169 FAMILY CLASSIC) (39 185 FAMILY CLASSIC))))) (*PFI-INDEX-ORDER* (QUOTE (FUNCTIONS))) (*PFI-DEFINER-PROPS* (LET ((*PACKAGE* (if (EQ MAKESYSNAME :LYRIC) then *INTERLISP-PACKAGE* else *KEYWORD-PACKAGE*))) (* ;; "Properties of definers changed between Lyric and Medley (yech).") (MAPCAR (QUOTE ("DEFINER-FOR" "DEFINED-BY" "DEFINITION-NAME")) (FUNCTION CL:INTERN)))) (\PFI.PROCESS.COMMANDS) (\PFI.PROCESSLOCK (CREATE.MONITORLOCK "PRETTYFILEINDEX")) (\PFI.PROCESS)) (COMS (* ;; "These are just in case our afternewpagefn escapes our dynamic context. *PFI-TITLE* being NIL means we're outside prettyfileindex") (INITVARS (*PFI-TITLE*) (*PFI-PAGE-COUNT* 0))) (ADDVARS (*PFI-TYPES* (ADVICE XCL:REINSTALL-ADVICE) (CONSTANTS CONSTANTS PFI.CONSTANTNAMES) (CONSTANTS CL:DEFCONSTANT) (COURIERPROGRAM COURIERPROGRAM) (DEFINERS DEFDEFINER) (I.S.OPR I.S.OPR) (MACRO DEFMACRO) (TEMPLATE SETTEMPLATE) (VARIABLES (RPAQ RPAQ? RPAQQ ADDTOVAR) PFI.VARNAME)) (*PFI-HANDLERS* (PUTPROPS . PFI.HANDLE.PUTPROPS) (DECLARE%: . PFI.HANDLE.DECLARE) (DEFINEQ . PFI.HANDLE.DEFINEQ) (PUTDEF . PFI.HANDLE.PUTDEF) (RPAQQ . PFI.HANDLE.RPAQQ) (DEFDEFINER . PFI.HANDLE.DEFDEFINER) (PRETTYCOMPRINT . NILL) (FILEMAP . PFI.HANDLE.FILEMAP) (* . PFI.HANDLE.*) (/DECLAREDATATYPE . PFI.HANDLE./DECLAREDATATYPE) (CL:IN-PACKAGE . PFI.HANDLE.PACKAGE) (CL:USE-PACKAGE . PFI.HANDLE.PACKAGE) (CL:SHADOW . PFI.HANDLE.PACKAGE) (CL:SHADOWING-IMPORT . PFI.HANDLE.PACKAGE) (IMPORT . PFI.HANDLE.PACKAGE) (EXPORT . PFI.HANDLE.PACKAGE) (CL:EVAL-WHEN . PFI.HANDLE.EVAL-WHEN)) (*PFI-PREVIEWERS* (DECLARE%: . PFI.PREVIEW.DECLARE) (DEFINEQ . PFI.PREVIEW.DEFINEQ)) (*PFI-PROPERTIES* (COPYRIGHT) (READVICE ADVICE)) (*PFI-FILTERS* (VARIABLES . CONSTANTS))) (COMS (* ; "Prettyprint augmentation to mimic system makefile dumping") (FNS PUTPROPS.PRETTYPRINT RPAQX.PRETTYPRINT COURIERPROGRAM.PRETTYPRINT MAYBE.PRETTYPRINT.BOLD) (ALISTS (PRETTYPRINTMACROS RPAQ RPAQQ RPAQ? ADDTOVAR PUTPROPS COURIERPROGRAM))) (DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T) (P (CL:PROCLAIM (QUOTE (CL:SPECIAL *PFI-PAGE-COUNT* *PFI-PAGE-PREFIX* *PFI-TITLE* *PFI-ITEM* *PFI-FNSLST* *PFI-INDEX-ALIST* *PFI-LOCATIONS* *PFI-FILEVARS* *PFI-FUNNY-CHARS* *PFI-PENDING-COMMENTS* *PFI-TWO-SIDED* *PFI-BITMAP-BASELINE* *OLD-INTERLISP-READ-ENVIRONMENT* *UPPER-CASE-FILE-NAMES* DEFAULTFONT BOLDFONT PRETTYCOMFONT LAMBDAFONT ITALICFONT FONTCHANGEFLG COMMENTFLG EMPRESS#SIDES PRETTYFLG)))) (RECORDS PFITYPE) (GLOBALVARS \PFI.PROCESS.COMMANDS \PFI.PROCESSLOCK \PFI.PROCESS NOTLISTEDFILES MACROPROPS CLISPRECORDTYPES PROMPTWINDOW *PFI-DEFINER-PROPS* *COMMON-LISP-READ-ENVIRONMENT*)) (DECLARE%: EVAL@COMPILE DOCOPY (* ; "Public variables to declare special") (P (CL:PROCLAIM (QUOTE (CL:SPECIAL *PFI-TYPES* *PFI-HANDLERS* *PFI-PREVIEWERS* *PFI-DONT-SPAWN* *PFI-PROPERTIES* *PFI-FILTERS* *PRINT-PRETTY-FROM-FILES* *PRINT-PRETTY-BITMAPS* *PFI-MAX-WASTED-LINES* *PFI-PRINTOPTIONS* *PFI-CHARACTER-TRANSLATIONS* *PFI-INDEX-ORDER*))))) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (OR (GETD (QUOTE CODEWRAPPER.PRETTYPRINT)) (FILESLOAD (SYSLOAD) DEFINERPRINT)) (* ; "Get prettyprinter fixes if running in old sysout") (MOVD? (PROG ((SYMS (QUOTE ("OLDLISTFILES1" "LISTFILES1-ORIGINAL"))) S) (* ; "Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.") LP (COND ((AND (SETQ S (CL:FIND-SYMBOL (CAR SYMS))) (GETD S)) (RETURN (PROG1 S (COND ((SETQ S (CL:FIND-SYMBOL "MAYBE-PP-CODE-FILE")) (* ; "Also fix SEE") (MOVD (QUOTE PFI.MAYBE.SEE.PRETTY) S NIL T)))))) ((SETQ SYMS (CDR SYMS)) (GO LP)) (T (* ; "Neither one loaded, take original") (RETURN (QUOTE LISTFILES1))))) (QUOTE PFI.ORIGINAL.LISTFILES1) NIL T) (MOVD (QUOTE PFI.NEW.LISTFILES1) (QUOTE LISTFILES1) NIL T) (CHANGENAME (QUOTE SEE) (QUOTE COPYALLBYTES) (QUOTE PFI.MAYBE.SEE.PRETTY)) (CHANGENAME (QUOTE FB.FASTSEE.ONEFILE) (QUOTE PFCOPYBYTES) (QUOTE PFI.MAYBE.SEE.PRETTY)) (CHANGENAME (QUOTE PRINTFNDEF) (QUOTE PFCOPYBYTES) (QUOTE PFI.MAYBE.PP.DEFINITION)) (MOVD? (OR (DEFPRINT (QUOTE BITMAP) (QUOTE PFI.PRINT.BITMAP)) (QUOTE NILL)) (QUOTE NON.PFI.PRINT.BITMAP) NIL T)))))
(* ;; "Variation on SINGLEFILEINDEX that prettyprints straight to the image stream.")
(DEFINEQ
(PFI.NEW.LISTFILES1
(LAMBDA (FILENAME PRINTOPTIONS) (* ; "Edited 12-May-88 12:52 by bvm") (* ;; "Substitute for LISTFILES1") (LET* ((*UPPER-CASE-FILE-NAMES* NIL) (FULL (FINDFILE FILENAME T))) (COND ((NOT FULL) (* ; "When called by LISTFILES, FILENAME will already be a full file name") (CL:ERROR (QUOTE XCL:FILE-NOT-FOUND) :PATHNAME FILENAME)) (*PFI-DONT-SPAWN* (MAYBE.PRETTYFILEINDEX FULL PRINTOPTIONS)) (T (PFI.ENQUEUE (LIST (FUNCTION MAYBE.PRETTYFILEINDEX) FULL PRINTOPTIONS)) FULL))))
)
(PFI.ENQUEUE
(LAMBDA (FORM) (* ; "Edited 12-May-88 12:52 by bvm") (* ;; "Add FORM to the background hardcopy's task list") (WITH.MONITOR \PFI.PROCESSLOCK (* ; "Lock protects \SFI.PROCESS.COMMANDS and \SFI.PROCESS") (COND ((AND \PFI.PROCESS (NOT (FIND.PROCESS \PFI.PROCESS))) (* ; "Process died, flush handle and any old listing requests") (SETQ \PFI.PROCESS (SETQ \PFI.PROCESS.COMMANDS NIL)))) (SETQ \PFI.PROCESS.COMMANDS (NCONC1 \PFI.PROCESS.COMMANDS FORM)) (COND ((NULL \PFI.PROCESS) (SETQ \PFI.PROCESS (ADD.PROCESS (LIST (FUNCTION \PFI.DO.HARDCOPY)) (QUOTE BEFOREEXIT) (QUOTE DON'T) (QUOTE NAME) "Do-Hardcopy"))))))
)
(\PFI.DO.HARDCOPY
(LAMBDA NIL (* ; "Edited 25-Mar-88 16:49 by bvm") (* ;;; "Process that takes listing commands from \SFI.PROCESS.COMMANDS and performs them") (WITH.MONITOR \PFI.PROCESSLOCK (* ; "Lock protects \SFI.PROCESS.COMMANDS and \SFI.PROCESS") (while \PFI.PROCESS.COMMANDS bind FORM do (SETQ FORM (pop \PFI.PROCESS.COMMANDS)) (RELEASE.MONITORLOCK \PFI.PROCESSLOCK) (* ; "Release lock while listing so that others can add to my queue") (APPLY (CAR FORM) (CDR FORM)) (OBTAIN.MONITORLOCK \PFI.PROCESSLOCK) finally (* ; "Nothing left to do, so exit") (SETQ \PFI.PROCESS NIL))))
)
(MAYBE.PRETTYFILEINDEX
(LAMBDA (FILENAME PRINTOPTIONS) (* ; "Edited 11-Apr-88 10:50 by bvm") (* ;;; "Performs PRETTYFILEINDEX on FILENAME if it is a file manager file, else calls the old listfiles1.") (COND ((COND ((PRETTYFILEINDEX FILENAME PRINTOPTIONS) T) (T (PFI.ORIGINAL.LISTFILES1 FILENAME PRINTOPTIONS))) (* ;; "Do this here since there is little coordination between the various multiple processes which are listing files") (SETQ NOTLISTEDFILES (REMOVE (ROOTFILENAME FILENAME) NOTLISTEDFILES)) NIL)))
)
)
(DEFINEQ
(PRETTYFILEINDEX
(LAMBDA (FILENAME PRINTOPTIONS OUTSTREAM DONTINDEX) (* ; "Edited 19-May-88 12:37 by bvm") (* ;; "Makes an indexed file (default is the line printer pseudo-file). The index file will have a number of indices, one for each indexable type. Each type index will list all the items of that type in alphabetical order and the page number of where that item's definition is in the file. The indices will be printed last, so that this can be one-pass.") (RESETLST (PROG ((*STANDARD-OUTPUT* *STANDARD-OUTPUT*) (*STANDARD-INPUT* *STANDARD-INPUT*) (*PRINT-ARRAY* T) (XCL:*PRINT-STRUCTURE* T) (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL) (*UPPER-CASE-FILE-NAMES* NIL) (PRETTYFLG T) (*PRINT-PRETTY-BITMAPS* (QUOTE PRETTYFILEINDEX)) (*PFI-PAGE-COUNT*) (*PFI-PAGE-PREFIX* "Page ") (*PFI-TWO-SIDED* (EQ (OR (LISTGET PRINTOPTIONS (QUOTE %#SIDES)) EMPRESS#SIDES) 2)) (*PFI-TITLE*) (*PFI-ITEM*) (*PFI-TYPES* *PFI-TYPES*) (*PFI-FILEVARS*) (*PFI-FNSLST*) (*PFI-LOCATIONS*) (*PFI-MAX-WASTED-LINES* *PFI-MAX-WASTED-LINES*) (*PFI-FUNNY-CHARS*) (*PFI-BITMAP-BASELINE*) (*PFI-PENDING-COMMENTS*) FILECREATED ENV WASOPEN MULTIFILEINDEX CRDATE INDICES PART# FIRSTPAGE LASTPAGE CRDATE) (* ;; "Specials are as follows:") (* ;; "*PRINT-PRETTY-BITMAPS* -- tells prettyprinter to render bitmap as its image") (* ;; "*PFI-PAGE-COUNT* -- number of current page") (* ;; "*PFI-TWO-SIDED* -- true if preparing two-sided listing") (* ;; "*PFI-TITLE* -- the file name, NIL to suppress headers") (* ;; "*PFI-ITEM* -- function, etc currently being printed") (* ;; "*PFI-TYPES* -- list specifying the type associated with an expression") (* ;; "*PFI-FILEVARS* -- alist of filevars we have discovered, along with their values. The first one is always mumbleCOMS. Use this in computing *PFI-FNSLST*") (* ;; "*PFI-FNSLST* -- list of functions known on this file. Used as the FNSLST arg to PRINTDEF") (* ;; "*PFI-LOCATIONS* -- list of (name type page#) constituting the actual index occurrences") (* ;; "*PFI-MAX-WASTED-LINES* -- the maximum number of lines we're willing to waste in order to get an expression all on one page.") (* ;; "*PFI-FUNNY-CHARS* -- alist of chars to translate to other chars") (* ;; "*PFI-BITMAP-BASELINE* -- kludge for printing bitmaps--set to baseline of bitmap we have printed below default") (* ;; "*PFI-PENDING-COMMENTS* -- (lineguess . bodies) of comments we have read but not yet printed") (* ;; "PRETTYFLG is bound here to insulate us from parallel (MAKEFILE & 'FAST) calls.") (if (TYPENAMEP FILENAME (QUOTE STREAM)) then (* ; "Already have input stream") (SETQ *STANDARD-INPUT* (SETQ WASOPEN (GETSTREAM FILENAME (QUOTE INPUT)))) else (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) (SETQ *STANDARD-INPUT* (OPENSTREAM FILENAME (QUOTE INPUT) (QUOTE OLD) (QUOTE ((SEQUENTIAL T)))))))) (SETQ FILENAME (FULLNAME *STANDARD-INPUT*)) (if (LISTGET PRINTOPTIONS :COMMON) then (* ; "Common Lisp file") (SETQ ENV *COMMON-LISP-READ-ENVIRONMENT*) else (* ; "Figure out if this is a file manager file, and if so get environment") (CL:MULTIPLE-VALUE-SETQ (ENV FILECREATED) (\PARSE-FILE-HEADER *STANDARD-INPUT* (QUOTE RETURN) T)) (if (NULL FILECREATED) then (* ; "Not a File Manager file") (RETURN NIL) elseif (NEQ (CAR (LISTP FILECREATED)) (QUOTE FILECREATED)) then (* ; "File started with open paren, but isn't file manager file.") (RETURN (if WASOPEN then (* ; "We have already read the first expression, so can't just return now (file may not be randaccessp). So dump what we read and then finish the copy") (PRINTDEF FILECREATED T T NIL NIL OUTSTREAM) (PFCOPYBYTES *STANDARD-INPUT* OUTSTREAM) (* ; "non-nil return says we did it") FILENAME)) elseif (LISTP (CADDR FILECREATED)) then (* ; "A compiled file--just use COPYBYTES to avoid binary hassles.") (RETURN (if WASOPEN then (* ; "Print environment and filecreated before copying rest") (PRINT-READER-ENVIRONMENT ENV OUTSTREAM) (WITH-READER-ENVIRONMENT ENV (PRINT FILECREATED OUTSTREAM)) (COPYBYTES *STANDARD-INPUT* OUTSTREAM) (* ; "non-nil return says we did it") FILENAME)))) (if OUTSTREAM then (SETQ *PFI-TITLE* FILENAME) (SETQ *STANDARD-OUTPUT* (GETSTREAM OUTSTREAM (QUOTE OUTPUT))) else (OR (SETQ *PFI-TITLE* (LISTGET PRINTOPTIONS (QUOTE DOCUMENT.NAME))) (push PRINTOPTIONS (QUOTE DOCUMENT.NAME) (SETQ *PFI-TITLE* FILENAME))) (SETQ *STANDARD-OUTPUT* (PFI.MAKE.LPT.STREAM PRINTOPTIONS)) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (STREAM NOPRINT) (if NOPRINT then (* ; "We only did this for the index (hack for MULTIFILEINDEX), so keep it from printing. Kludge: do it by closing the stream manually") (\CORE.CLOSEFILE STREAM) (replace (STREAM ACCESS) of STREAM with NIL) (\GENERIC-UNREGISTER-STREAM (fetch (STREAM DEVICE) of STREAM) STREAM) (\CORE.DELETEFILE (FULLNAME STREAM) (fetch (STREAM DEVICE) of STREAM)) else (CLOSEF? STREAM)))) *STANDARD-OUTPUT* (LISTGET PRINTOPTIONS :DONTPRINT)))) (* ; "Make sure printer knows original name of file") (RESETSAVE (LINELENGTH (IQUOTIENT (- (DSPRIGHTMARGIN) (DSPLEFTMARGIN)) (CHARWIDTH (CHARCODE X) *STANDARD-OUTPUT*)) *STANDARD-OUTPUT*)) (if (NOT (DISPLAYSTREAMP *STANDARD-OUTPUT*)) then (PFI.SETUP.TRANSLATIONS)) (if DONTINDEX then (* ; "This is for SEE etc") (SETQ *PFI-MAX-WASTED-LINES* 0) (SETQ *PFI-TYPES* NIL) (* ; "Tell add.to.index not to bother") (SETQ *PFI-LOCATIONS* :NONE) else (STREAMPROP *STANDARD-OUTPUT* (QUOTE AFTERNEWPAGEFN) (FUNCTION PFI.AFTER.NEW.PAGE)) (* ; "Enable header printing") (SETQ *PFI-FILEVARS* (BQUOTE (((\, (FILECOMS FILENAME)) . NOBIND)))) (* ; "Says to do something with coms") (if (NOT (FIXP *PFI-MAX-WASTED-LINES*)) then (* ; "a parameter expressed as a fraction of page") (SETQ *PFI-MAX-WASTED-LINES* (FIXR (TIMES *PFI-MAX-WASTED-LINES* (- (PFI.LINES.REMAINING) 2))))) (SETQ *PFI-TYPES* (APPEND *PFI-TYPES* (CONS (BQUOTE (RECORD (\, CLISPRECORDTYPES))) (PFI.COLLECT.DEFINERS *PFI-TYPES*)))) (* ; "Add known record types and definers to the list.") (SETQ CRDATE (GETFILEINFO *STANDARD-INPUT* (QUOTE CREATIONDATE)))) (SETQ *PFI-PAGE-COUNT* (SETQ FIRSTPAGE (LOGOR (OR (LISTGET PRINTOPTIONS :FIRSTPAGE) 1) (if *PFI-TWO-SIDED* then (* ; "Make first page odd") 1 else 0)))) (if (SETQ PART# (LISTGET PRINTOPTIONS :PART)) then (SETQ *PFI-PAGE-PREFIX* (CONCAT *PFI-PAGE-PREFIX* PART# "-"))) (RETURN (WITH-READER-ENVIRONMENT ENV (if FILECREATED then (PFI.PRINT.FILECREATED FILECREATED ENV)) (PFI.PROCESS.FILE DONTINDEX) (if (NOT WASOPEN) then (* ; "We're through with input file now, so release it") (CLOSEF *STANDARD-INPUT*)) (if (SETQ MULTIFILEINDEX (LISTGET PRINTOPTIONS (QUOTE MULTIFILEINDEX))) then (* ; "True on calls from multifileindex-remember the date and last page#") (SETQ LASTPAGE *PFI-PAGE-COUNT*)) (if (NOT DONTINDEX) then (* ; "Now that we've scanned whole file, print the index") (SETQ INDICES (PFI.PRINT.INDEX CRDATE))) (if (NULL OUTSTREAM) then (CL:FORMAT PROMPTWINDOW "~%%Finished indexing ~A (~D pages)" FILENAME (ADD1 (- *PFI-PAGE-COUNT* FIRSTPAGE)))) (if (NULL MULTIFILEINDEX) then FILENAME else (push INDICES (LIST FILENAME CRDATE LASTPAGE ENV)) (if (NLISTP MULTIFILEINDEX) then (* ; "More to do yet, so just return this index") INDICES else (PFI.PRINT.MULTI.INDEX (NCONC1 MULTIFILEINDEX INDICES) PRINTOPTIONS))))))))
)
(PFI.MAKE.LPT.STREAM
(LAMBDA (PRINTOPTIONS) (* ; "Edited 18-May-88 19:24 by bvm") (LET ((PRINTER (OR (LISTGET PRINTOPTIONS (QUOTE SERVER)) (LISTGET PRINTOPTIONS (QUOTE HOST)))) (DEFAULTOPTIONS *PFI-PRINTOPTIONS*) REG S) (if (AND (LISTGET PRINTOPTIONS (QUOTE LANDSCAPE)) (SETQ REG (LISTGET DEFAULTOPTIONS (QUOTE REGION)))) then (* ; "Don't use default region when caller specified landscape (tee hee)") (SETQ DEFAULTOPTIONS (for TAIL on DEFAULTOPTIONS by (CDDR TAIL) unless (EQ (CAR TAIL) (QUOTE REGION)) join (LIST (CAR TAIL) (CADR TAIL)))) elseif (AND *PFI-TWO-SIDED* (SETQ REG (LISTGET DEFAULTOPTIONS (QUOTE REGION))) (NOT (LISTGET PRINTOPTIONS (QUOTE REGION)))) then (* ; "Shift image to the left 1/4%" so that it is balanced. Default region is assumed to be 1%" on left and 1/2%" on right. No adjustment if user gave region explicitly") (LISTPUT (SETQ DEFAULTOPTIONS (APPEND DEFAULTOPTIONS)) (QUOTE REGION) (create REGION using REG LEFT ← (- (fetch (REGION LEFT) of REG) (IQUOTIENT MICASPERINCH 4))))) (SETQ PRINTOPTIONS (APPEND PRINTOPTIONS DEFAULTOPTIONS)) (SETQ S (if PRINTER then (OPENIMAGESTREAM (CONCAT "{LPT}" PRINTER) (CAR (PRINTERPROP (PRINTERTYPE PRINTER) (QUOTE CANPRINT))) PRINTOPTIONS) else (* ; "Use default printer & type") (OPENIMAGESTREAM NIL NIL PRINTOPTIONS))) (STREAMPROP S (QUOTE PRINTOPTIONS) (APPEND PRINTOPTIONS (STREAMPROP S (QUOTE PRINTOPTIONS)))) S))
)
(PFI.SETUP.TRANSLATIONS
(LAMBDA NIL (* ; "Edited 14-Apr-88 11:51 by bvm") (* ;; "Prepare character translation table for this output stream") (* ;; "*PFI-CHARACTER-TRANSLATIONS* is an alist of (imagetype . charpairs), where each char pair is (sourcecode destcode . fontplist) describing the translation and optional font change for a specified input character. We set *PFI-FUNNY-CHARS* to (oldoutcharfn . triples), where each triple is (sourcecode destcode fontplist . fontcacheplist). ") (LET ((CHARPAIRS (CDR (ASSOC (IMAGESTREAMTYPE *STANDARD-OUTPUT*) *PFI-CHARACTER-TRANSLATIONS*)))) (SETQ *PFI-FUNNY-CHARS* (CONS (fetch (STREAM OUTCHARFN) of *STANDARD-OUTPUT*) (AND CHARPAIRS (LET ((FONT (DSPFONT))) (if (NEQ (CHARWIDTH (CHARCODE i) FONT) (CHARWIDTH (CHARCODE W) FONT)) then (* ; "Font is not fixed width, so don't need this kludge when substituting fonts") (SETQ FONT NIL)) (for PAIR in CHARPAIRS collect (* ;; "Each entry is (oldchar newchar . fontspec), where fontspec is optional plist to give to FONTCOPY to get a font derived from current font to print the char. Here we copy each entry, preparing cache for font change entries") (LIST* (pop PAIR) (pop PAIR) PAIR (if FONT then (* ; "First oldfont-newfont pair designates a fixed-width font") (LIST FONT (CL:APPLY (FUNCTION FONTCOPY) FONT PAIR)) else (* ; "Just waste this fixed-width entry") (LIST NIL NIL)))))))) (if CHARPAIRS then (* ; "Yes, want translation") (replace (STREAM OUTCHARFN) of *STANDARD-OUTPUT* with (FUNCTION PFI.OUTCHARFN)))))
)
(PFI.OUTCHARFN
(LAMBDA (STREAM CHAR) (* ; "Edited 14-Apr-88 12:40 by bvm") (* ;; "Our own OUTCHARFN that does character translation.") (DESTRUCTURING-BIND (FN . CASES) *PFI-FUNNY-CHARS* (do (if (NULL CASES) then (* ; "Not funny, just do it regular") (if (AND (EQ CHAR (CHARCODE EOL)) *PFI-BITMAP-BASELINE*) then (* ; "End of line on a line where we have printed bitmaps below the baseline--make sure we terpri far enough") (if (AND *PFI-BITMAP-BASELINE* (< *PFI-BITMAP-BASELINE* (DSPYPOSITION NIL STREAM))) then (* ; "Could be false if new page in between") (MOVETO (DSPXPOSITION NIL STREAM) *PFI-BITMAP-BASELINE* STREAM)) (SETQ *PFI-BITMAP-BASELINE* NIL) (if (NULL (CDR *PFI-FUNNY-CHARS*)) then (* ; "We existed only for this kludge--restore normal outcharfn") (replace (STREAM OUTCHARFN) of STREAM with FN))) (RETURN (CL:FUNCALL FN STREAM CHAR)) elseif (EQ (CAAR CASES) CHAR) then (* ; "Yes, it's a special char") (RETURN (DESTRUCTURING-BIND (C . FONTINFO) (CDAR CASES) (if (NULL FONTINFO) then (* ; "Simple translation in this font") (CL:FUNCALL FN STREAM C) else (* ; "Want to use char from another font") (LET* ((FONT (DSPFONT NIL STREAM)) (NEWFONT (LISTGET (CDR FONTINFO) FONT)) EXTRASPACE) (if (NOT NEWFONT) then (* ; "Other font not cached yet. FONTINFO = (spec . fontplist), where SPEC is something to give to FONTCOPY to modify the current font.") (NCONC FONTINFO (LIST FONT (SETQ NEWFONT (CL:APPLY (FUNCTION FONTCOPY) FONT (CAR FONTINFO)))))) (DSPFONT NEWFONT STREAM) (if (AND (EQ FONT (CADR FONTINFO)) (> (SETQ EXTRASPACE (- (CHARWIDTH C FONT) (CHARWIDTH C NEWFONT))) 0)) then (* ; "We were in a fixed width font, but substitution is from a font where the char is narrower, so make some space to maintain the fixed-width illusion.") (RELMOVETO (IQUOTIENT EXTRASPACE 2) 0 STREAM) (CL:FUNCALL FN STREAM C) (RELMOVETO (- EXTRASPACE (IQUOTIENT EXTRASPACE 2)) 0 STREAM) else (CL:FUNCALL FN STREAM C)) (DSPFONT FONT STREAM))))) else (SETQ CASES (CDR CASES))))))
)
(PFI.COLLECT.DEFINERS
(LAMBDA (KNOWNTYPES) (* ; "Edited 11-Apr-88 12:26 by bvm") (* ;; "Scan all the definers in the system, creating PFITYPE entries for them if they're not already in the entries in KNOWNTYPES (e.g., might want DEFMACRO to be MACROS not FUNCTIONS). Bunch of conditionals in here because between Lyric and Medley the prop names changed from IL symbols to keywords. *PFI-DEFINER-PROPS* = (:definer-for :defined-by :definition-name)") (for TYPE in FILEPKGTYPES bind (BYPROP ← (CADR *PFI-DEFINER-PROPS*)) (NAMEPROP ← (CADDR *PFI-DEFINER-PROPS*)) when (LITATOM TYPE) join (for DEFINER in (GET TYPE BYPROP) collect (create PFITYPE NAME ← TYPE PATTERNS ← DEFINER TESTFN ← (GET DEFINER NAMEPROP)) unless (for ENTRY in KNOWNTYPES thereis (EQMEMB DEFINER (fetch (PFITYPE PATTERNS) of ENTRY))))))
)
(PFI.AFTER.NEW.PAGE
(LAMBDA (STREAM) (* ; "Edited 12-May-88 09:58 by bvm") (DECLARE (USEDFREE *PFI-TITLE* *PFI-ITEM* *PFI-PAGE-COUNT*)) (* ;; "Called after the output image stream has turned the page. Bump our page count and print a suitable header.") (add *PFI-PAGE-COUNT* 1) (if *PFI-TITLE* then (LET ((*PRINT-BASE* 10) (LEFT *PFI-TITLE*) (RIGHT) (OLDFONT (DSPFONT))) (CHANGEFONT DEFAULTFONT) (* ; "Get back to canonical font for the header, saving whatever font was in effect at the page turn") (if (EQ *PFI-ITEM* :INDEX) then (* ; "In the index, omit page numbers") (SETQ *PFI-ITEM* NIL) else (SETQ RIGHT (CONCAT *PFI-PAGE-PREFIX* *PFI-PAGE-COUNT*))) (if (AND *PFI-TWO-SIDED* (EVENP *PFI-PAGE-COUNT*)) then (* ; "On even pages, print page numbers on outside (left)") (swap LEFT RIGHT)) (if LEFT then (PRIN3 LEFT)) (if (AND *PFI-ITEM* (NEQ *PFI-ITEM* :INDEX)) then (printout NIL " (" .FONT BOLDFONT |.P2| *PFI-ITEM* .FONT ITALICFONT " cont." .FONT DEFAULTFONT ")")) (if RIGHT then (DSPXPOSITION (- (DSPRIGHTMARGIN) (STRINGWIDTH RIGHT STREAM))) (PRIN3 RIGHT)) (TERPRI) (TERPRI) (DSPFONT OLDFONT))))
)
)
(DEFINEQ
(PFI.PRINT.FILECREATED
(LAMBDA (EXPR ENV) (* ; "Edited 13-Apr-88 11:14 by bvm") (* ;; "Display the FILECREATED expression and environment prettily") (* ;; "Form is (FILECREATED date filename filemaploc changes to: changes previous date: date filename)") (pop EXPR) (CHANGEFONT ITALICFONT) (LET* ((STRINGS (QUOTE ("File created:" "changes to:" "previous date:" "Read Table:" "Package:" "Base:"))) (FONT (DSPFONT)) (STRWIDTHS (for STR in STRINGS collect (STRINGWIDTH STR FONT))) (TABSTOP (+ (DSPLEFTMARGIN) (APPLY (FUNCTION MAX) STRWIDTHS)))) (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (* ; "File created:") (PRINTOUT NIL (pop EXPR) " " .FONT LAMBDAFONT (pop EXPR) T T) (* ; "date and file name") (if (OR (NULL (CAR EXPR)) (FIXP (CAR EXPR))) then (* ; "Skip over filemaploc") (pop EXPR)) (if (EQ (CAR EXPR) (QUOTE changes)) then (* ; "handle %"Changes to:%"") (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (SETQ EXPR (CDDR EXPR)) (PRINTDEF (while (LISTP (CAR EXPR)) collect (pop EXPR)) T NIL T) (TERPRI) (TERPRI) else (pop STRINGS) (pop STRWIDTHS)) (if (EQ (CAR EXPR) (QUOTE previous)) then (* ; "Handle %"Previous date:%"") (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (SETQ EXPR (CDDR EXPR)) (PRINTOUT NIL (pop EXPR) " " (pop EXPR) T T) else (pop STRINGS) (pop STRWIDTHS)) (LET ((SPEC (fetch RESPEC of ENV))) (* ; "Show environment") (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (* ; "Read table") (PFI.PRINT.ENVIRONMENT SPEC :READTABLE) (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (* ; "Package") (PFI.PRINT.ENVIRONMENT SPEC :PACKAGE) (if (NEQ *PRINT-BASE* 10) then (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (PFI.PRINT.ENVIRONMENT SPEC :BASE)))))
)
(PFI.PRINT.TO.TAB
(LAMBDA (STR WIDTH TABSTOP) (* ; "Edited 29-Mar-88 12:44 by bvm") (* ;; "Print STR of specified WIDTH right-justified to xpos TABSTOP in italic font, leave a couple of spaces, then switch back to defaultfont.") (CHANGEFONT ITALICFONT) (DSPXPOSITION (- TABSTOP WIDTH)) (PRIN3 STR) (RELMOVETO (TIMES 12 (DSPSCALE)) 0) (CHANGEFONT DEFAULTFONT))
)
(PFI.PRINT.ENVIRONMENT
(LAMBDA (SPEC KEYWORD) (* ; "Edited 29-Mar-88 12:46 by bvm") (* ;; "Display the KEYWORD component of a reader environment spec") (LET ((VALUE (LISTGET SPEC KEYWORD))) (if (LISTP VALUE) then (* ; "An expression to create it--show pretty. Use IL package, since that's what they appear in at beginning of file") (LET ((*PACKAGE* *INTERLISP-PACKAGE*)) (PRINTDEF VALUE T T)) else (* ; "Just show the value, sans quotations, etc. The selectq is just in case this environment has no spec, something that shouldn't happen if it came from a define-file-info") (PRIN3 (OR VALUE (SELECTQ KEYWORD (:READTABLE (READTABLEPROP *READTABLE* (QUOTE NAME))) (:PACKAGE (CL:PACKAGE-NAME *PACKAGE*)) (SHOULDNT))))) (TERPRI) (TERPRI)))
)
)
(DEFINEQ
(PFI.PROCESS.FILE
(LAMBDA (DONTINDEX) (* ; "Edited 13-Apr-88 12:59 by bvm") (* ;; "The main loop for PRETTYFILEINDEX--process expressions on the file until we're done.") (bind CH FN EXPR while (SETQ CH (SKIPSEPRCODES)) do (if (EQ CH (CHARCODE ";")) then (PFI.PASS.COMMENT) elseif (AND DONTINDEX (EQ CH (CHARCODE "("))) then (* ;; "From SEE. Want to have a look at the car so we don't take a long time reading the WHOLE expression that we can easily process in pieces, like DEFINEQ") (READCCODE) (* ; "Eat the paren") (if (AND (NOT (SYNTAXP (SKIPSEPRCODES) (QUOTE RIGHTPAREN))) (LITATOM (SETQ FN (CL:READ))) (SETQ EXPR (ASSOC FN *PFI-PREVIEWERS*))) then (* ; "Next thing was a symbol, and we have a previewer for this kind of expression--do it. SYNTAXP is just in case we encountered ( ).") (if *PFI-PENDING-COMMENTS* then (* ; "First dispose of pending comments") (PFI.PRINT.COMMENTS)) (CL:FUNCALL (CDR EXPR) FN) else (* ; "Failed--fall back on reading the whole thing") (PFI.HANDLE.EXPR (CONS FN (CL:READ-DELIMITED-LIST #\))))) elseif (OR (EQ (SETQ EXPR (CL:READ *STANDARD-INPUT* NIL *STANDARD-INPUT*)) *STANDARD-INPUT*) (EQ EXPR (QUOTE STOP))) then (* ; "Hit end of file") (RETURN) else (PFI.HANDLE.EXPR EXPR)) (BLOCK)))
)
(PFI.PASS.COMMENT
(LAMBDA NIL (* ; "Edited 15-Apr-88 18:16 by bvm") (* ;; "Copy a semi-colon comment to the output stream") (TERPRI) (CHANGEFONT COMMENTFONT) (bind CH do (if (NEQ (SETQ CH (READCCODE *STANDARD-INPUT*)) (CHARCODE EOL)) then (* ; "Pass a character") (\OUTCHAR *STANDARD-OUTPUT* CH) else (TERPRI) (if (NEQ (PEEKCCODE *STANDARD-INPUT* T) (CHARCODE ";")) then (* ; "End of comment") (RETURN)))) (CHANGEFONT DEFAULTFONT))
)
(PFI.HANDLE.EXPR
(LAMBDA (EXPR) (* ; "Edited 11-Apr-88 17:56 by bvm") (* ;; "Prettyprint the expression we just read to the output file, and also do any appropriate indexing") (if (AND *PFI-PENDING-COMMENTS* (NEQ (CAR (LISTP EXPR)) COMMENTFLG)) then (* ; "Dispose of pending comments") (PFI.PRINT.COMMENTS EXPR)) (if (NLISTP EXPR) then (* ; "Not a form") (TERPRI) (PRINT EXPR) elseif (NOT (LITATOM (CAR EXPR))) then (* ; "Odd random form on file. I hope the car is actually a lambda expression") (TERPRI) (PFI.MAYBE.NEW.PAGE EXPR) (PFI.PRETTYPRINT EXPR NIL T) else (CL:FUNCALL (OR (CDR (ASSOC (CAR EXPR) *PFI-HANDLERS*)) (FUNCTION PFI.DEFAULT.HANDLER)) EXPR)))
)
(PFI.DEFAULT.HANDLER
(LAMBDA (EXPR) (* ; "Edited 11-Apr-88 17:54 by bvm") (* ;; "The default handler for an expression. Looks up in *PFI-TYPES* for matching entries, then prettyprints the expression.") (LET ((CAR-OF-FORM (CAR EXPR)) PAT ITEMNAME MAINITEM TESTFN TEMPLATE) (if (GET CAR-OF-FORM (CAR *PFI-DEFINER-PROPS*)) then (* ; "Put a little extra space before definers") (TERPRI)) (PFI.MAYBE.NEW.PAGE EXPR) (SETQ TEMPLATE (GET CAR-OF-FORM :DEFINITION-PRINT-TEMPLATE)) (for ENTRY in *PFI-TYPES* when (COND ((EQ (SETQ PAT (fetch (PFITYPE PATTERNS) of ENTRY)) T) (* ; "Matches anything -- TESTFN must be doing all the work") T) ((LISTP PAT) (MEMB CAR-OF-FORM PAT)) (T (EQ CAR-OF-FORM PAT))) do (SETQ TESTFN (fetch (PFITYPE TESTFN) of ENTRY)) (COND ((NULL TESTFN) (* ; "Extract default name") (if (NLISTP (SETQ ITEMNAME (if (AND TEMPLATE (MEMB :NAME TEMPLATE)) then (* ; "We're told more explicitly where the name is") (CL:NTH (CL:POSITION :NAME TEMPLATE) (CDR EXPR)) else (* ; "Name defaultly is second elt") (CADR EXPR)))) then (if (AND ITEMNAME (OR (LITATOM ITEMNAME) (STRINGP ITEMNAME))) then (PFI.ADD.TO.INDEX (SETQ MAINITEM ITEMNAME) ENTRY)) elseif (EQ (CAR ITEMNAME) (QUOTE QUOTE)) then (* ; "A quoted form, like (I.S.OPR 'COLLECT ...)") (PFI.ADD.TO.INDEX (SETQ MAINITEM (CADR ITEMNAME)) ENTRY) elseif (AND (SETQ ITEMNAME (CAR ITEMNAME)) (OR (LITATOM ITEMNAME) (STRINGP ITEMNAME))) then (* ; "Some definer that takes a (name . options) slot here") (PFI.ADD.TO.INDEX (SETQ MAINITEM ITEMNAME) ENTRY))) ((SETQ ITEMNAME (CAR (NLSETQ (CL:FUNCALL TESTFN EXPR ENTRY)))) (COND ((NLISTP ITEMNAME) (* ; "Single object to be indexed as the type in ENTRY") (PFI.ADD.TO.INDEX (SETQ MAINITEM ITEMNAME) ENTRY)) (T (* ; "Index as some other type") (for PAIR in (COND ((LITATOM (CAR ITEMNAME)) (* ; "a single pair") (LIST ITEMNAME)) (T (* ; "many") ITEMNAME)) do (for NAME in (CDR PAIR) do (push *PFI-LOCATIONS* (LIST (CAR PAIR) NAME *PFI-PAGE-COUNT*)))))) (COND ((NOT (fetch (PFITYPE AMBIGUOUS?) of ENTRY)) (RETURN)))))) (PFI.PRETTYPRINT EXPR MAINITEM T)))
)
(PFI.PRETTYPRINT
(LAMBDA (EXPR NAME FORMFLG) (* ; "Edited 7-Apr-88 11:06 by bvm") (* ;; "Prettyprints EXPR. NAME is the %"name%" of the thing being prettyprinted, for benefit of header hackers. FORMFLG is true if thing should be printed as code.") (LET ((*PFI-ITEM* NAME)) (PRINTDEF EXPR T FORMFLG NIL *PFI-FNSLST*)) (TERPRI))
)
(PFI.LINES.REMAINING
(LAMBDA NIL (* ; "Edited 11-Apr-88 17:23 by bvm") (* ;; "Returns number of lines left on this page, or a large number if stream does not tell us") (LET ((BOTTOM (DSPBOTTOMMARGIN))) (if (NULL BOTTOM) then 999 else (ADD1 (IQUOTIENT (- (DSPYPOSITION) BOTTOM) (- (DSPLINEFEED NIL *STANDARD-OUTPUT*)))))))
)
(PFI.MAYBE.NEW.PAGE
(LAMBDA (EXPR MINLINES) (* ; "Edited 13-Apr-88 14:32 by bvm") (* ;; "Maybe start a new page if it looks like EXPR will overflow the page and we're near the end of the page. MINLINES is optional size estimate; else we guess") (LET (REMAINING) (if (OR (DISPLAYSTREAMP *STANDARD-OUTPUT*) (> (SETQ REMAINING (SUB1 (PFI.LINES.REMAINING))) *PFI-MAX-WASTED-LINES*) (>= REMAINING (OR MINLINES (PFI.ESTIMATE.SIZE EXPR)))) then (TERPRI) else (* ; "put it on a new page") (DSPNEWPAGE))))
)
(PFI.ESTIMATE.SIZE
(LAMBDA (EXPR) (* ; "Edited 11-Apr-88 17:37 by bvm") (* ;; "Guess how many lines EXPR will take, so that we can try getting it all on one page if we're near the bottom. Heuristic is that after the first list element in any element, each subsequent element gets its own line") (+ (LET ((TEMPLATE (AND (LITATOM (CAR EXPR)) (GET (CAR EXPR) :DEFINITION-PRINT-TEMPLATE)))) (if (AND TEMPLATE (MEMB :BODY TEMPLATE)) then (* ; "Make extra space for things that have body") 2 else 1)) (PFI.ESTIMATE.SIZE1 EXPR 0)))
)
(PFI.ESTIMATE.SIZE1
(LAMBDA (EXPR INITSUM) (* ; "Edited 13-Apr-88 11:24 by bvm") (* ;; "Recursive part of PFI.ESTIMATE.SIZE's heuristic. We add on to INITSUM, and stop when it looks pointless to dive deeper. Heuristic says we have a new line every time there's a list element with something after it.") (if (LISTP EXPR) then (LET ((TAIL (SOME EXPR (FUNCTION LISTP)))) (add INITSUM (LENGTH (CDR TAIL))) (until (OR (NLISTP TAIL) (> INITSUM *PFI-MAX-WASTED-LINES*)) do (SETQ INITSUM (PFI.ESTIMATE.SIZE1 (pop TAIL) INITSUM))))) INITSUM)
)
)
(* ; "Expression handlers")
(DEFINEQ
(PFI.HANDLE.RPAQQ
(LAMBDA (EXPR) (* ; "Edited 7-Apr-88 11:09 by bvm") (PFI.MAYBE.NEW.PAGE EXPR) (LET* ((NAME (CADR EXPR)) (COMSINFO (ASSOC NAME *PFI-FILEVARS*))) (COND ((AND COMSINFO (EQ (CDR COMSINFO) (QUOTE NOBIND))) (* ; "We don't yet know the value of this filevar, so here it is.") (RPLACD COMSINFO (CADDR EXPR)) (LET ((*MAINFILECOMS* (CDAR *PFI-FILEVARS*)) VARS VALUES) (* ;; "*PFI-FILEVARS* is an alist of (filevar . value), for all filevars we've discovered so far and any values of same. Since we have newly discovered the value of this var, the INFILECOMS? below may have changed some, so reevaluate them.") (for PAIR in (CDR *PFI-FILEVARS*) unless (EQ (CDR PAIR) (QUOTE NOBIND)) do (push VARS (CAR PAIR)) (push VALUES (CDR PAIR))) (CL:PROGV VARS VALUES (SETQ *PFI-FNSLST* (APPEND (INFILECOMS? NIL (QUOTE FNS) *MAINFILECOMS*) (INFILECOMS? NIL (QUOTE FUNCTIONS) *MAINFILECOMS*))) (for FV in (INFILECOMS? NIL (QUOTE FILEVARS) *MAINFILECOMS*) unless (OR (ASSOC FV *PFI-FILEVARS*) (BOUNDP FV)) do (* ;; "Add to the list any new filevars uncovered by this evaluation. Don't bother if they're already bound in the sysout, since then their values have already been made use of.") (push (CDR *PFI-FILEVARS*) (CONS FV (QUOTE NOBIND)))))))) (if (NEQ NAME (CAAR *PFI-FILEVARS*)) then (* ; "Don't bother indexing the main COMS") (PFI.ADD.TO.INDEX NAME (QUOTE VARIABLES))) (PFI.PRETTYPRINT EXPR NAME)))
)
(PFI.HANDLE.DECLARE
(LAMBDA (EXPR) (* ; "Edited 7-Apr-88 12:33 by bvm") (* ;; "Handle (DECLARE: tags coms ...)") (if (NOT (LET ((TAIL (CDR EXPR))) (* ;; "Filter out (DECLARE: DONTCOPY (FILEMAP --))") (AND (LISTP TAIL) (EQ (pop TAIL) (QUOTE DONTCOPY)) (LISTP TAIL) (EQ (CAR (LISTP (pop TAIL))) (QUOTE FILEMAP)) (NULL TAIL)))) then (TERPRI) (PRIN1 "(") (PROG (STARTOFLINE NEXT) TOP (SETQ STARTOFLINE T) NEXTITEM (if (NLISTP EXPR) then (* ; "Done, except for possible malformed dotted tail") (PRINTDEF EXPR T T T) (PRIN1 ")") (TERPRI) (RETURN)) (if (NLISTP (SETQ NEXT (pop EXPR))) then (* ; "Print the declare tags (and the declare: itself) all on one line, boringly") (if STARTOFLINE then (SETQ STARTOFLINE NIL) else (SPACES 1)) (PRIN2 NEXT) (GO NEXTITEM)) (* ;; "Have an interesting com, so go to new line and process it") (TERPRI) (do (PFI.HANDLE.EXPR NEXT) repeatwhile (AND (LISTP EXPR) (LISTP (SETQ NEXT (pop EXPR))))) (GO TOP))))
)
(PFI.HANDLE.EVAL-WHEN
(LAMBDA (EXPR) (* ; "Edited 23-Apr-88 16:51 by bvm") (* ;; "Handle EVAL-WHEN. This is a lot like DECLARE: -- the inner expressions get treated as top-level.") (PFI.MAYBE.NEW.PAGE NIL (+ 2 (PFI.ESTIMATE.SIZE (CADDR EXPR)))) (* ; "Make space for the first expression, plus the eval-when & .. line") (PRIN1 "(") (PRIN2 (pop EXPR)) (SPACES 1) (PRINT (pop EXPR)) (while (LISTP EXPR) do (PFI.HANDLE.EXPR (pop EXPR))) (PRINTDEF EXPR T T T) (PRIN1 ")") (TERPRI))
)
(PFI.HANDLE.DEFDEFINER
(LAMBDA (EXPR) (* ; "Edited 12-Apr-88 11:16 by bvm") (* ;; "Notice DEFDEFINER expressions. We don't actually evaluate them (let's not side-effect the environment too much), but notice that we should index them and that they should prettyprint interestingly.") (PFI.MAYBE.NEW.PAGE EXPR) (LET ((DEFINER (CADR EXPR)) OPTIONS) (if (LISTP DEFINER) then (SETQ OPTIONS (CDR DEFINER)) (SETQ DEFINER (CAR DEFINER))) (if (NOT (LITATOM DEFINER)) then (* ; "Bogus") (SETQ DEFINER NIL) elseif *PFI-TYPES* then (* ; "We're indexing, maybe add this type") (if (NOT (for ENTRY in *PFI-TYPES* thereis (EQMEMB DEFINER (fetch (PFITYPE PATTERNS) of ENTRY)))) then (* ; "We don't know about this one yet") (push *PFI-TYPES* (create PFITYPE NAME ← (CADDR EXPR) PATTERNS ← DEFINER TESTFN ← (CADR (ASSOC :NAME OPTIONS))))) (if (NOT (ASSOC DEFINER PRETTYPRINTMACROS)) then (* ; "Help it prettyprint better") (push PRETTYPRINTMACROS (CONS DEFINER (CL:INTERN "PPRINT-DEFINER" (CL:FIND-PACKAGE (if (EQ MAKESYSNAME :LYRIC) then "IL" else "XCL"))))) (if (AND (SETQ OPTIONS (ASSOC :TEMPLATE OPTIONS)) (NOT (GET DEFINER :DEFINITION-PRINT-TEMPLATE))) then (PUT DEFINER :DEFINITION-PRINT-TEMPLATE (CADR OPTIONS)))) (PFI.ADD.TO.INDEX DEFINER (QUOTE DEFINERS))) (PFI.PRETTYPRINT EXPR DEFINER T)))
)
(PFI.HANDLE.DEFINEQ
(LAMBDA (EXPR) (* ; "Edited 7-Apr-88 12:34 by bvm") (* ;; "Handle (DEFINEQ (fn1 . def) (fn2 . def) ...)") (TERPRI) (PRIN1 "(") (PRINT (CAR EXPR)) (for DEF in (CDR EXPR) do (PFI.PRINT.LAMBDA DEF)) (PRIN1 ")") (TERPRI))
)
(PFI.PRINT.LAMBDA
(LAMBDA (DEF) (* ; "Edited 11-Apr-88 17:21 by bvm") (* ;; "Print one piece of a DEFINEQ. DEF is (fn (lambda ...)).") (PFI.MAYBE.NEW.PAGE NIL (PFI.ESTIMATE.SIZE1 (CDR DEF) 3)) (LET ((*PFI-ITEM* (CAR DEF))) (PFI.ADD.TO.INDEX *PFI-ITEM* (QUOTE FUNCTIONS)) (PFI.PRINT.LAMBDA.BODY DEF *PFI-FNSLST*)) (TERPRI) (TERPRI))
)
(PFI.PRINT.LAMBDA.BODY
(LAMBDA (DEF FNSLST) (* ; "Edited 29-Mar-88 18:46 by bvm") (* ;; "Just the stuff that prints a lambda form. DEF = (name (lambda ...))") (PRIN1 "(") (CHANGEFONT (OR LAMBDAFONT BOLDFONT)) (PRIN2 (CAR DEF)) (CHANGEFONT DEFAULTFONT) (TERPRI) (SPACES 2) (PRINTDEF (CDR DEF) T (QUOTE FNS) T FNSLST) (PRIN1 ")"))
)
(PFI.HANDLE.PUTDEF
(LAMBDA (EXPR) (* ; "Edited 7-Apr-88 11:10 by bvm") (* ;; "Called to handle PUTDEF. If in form (PUTDEF 'name 'type 'value), we can index name by type.") (PFI.MAYBE.NEW.PAGE EXPR) (DESTRUCTURING-BIND (NAME TYPE) EXPR (PFI.PRETTYPRINT EXPR (if (AND (LISTP NAME) (EQ (CAR NAME) (QUOTE QUOTE)) (LISTP TYPE) (EQ (CAR TYPE) (QUOTE QUOTE)) (LITATOM (SETQ TYPE (CADR TYPE)))) then (PFI.ADD.TO.INDEX (SETQ NAME (CADR NAME)) TYPE) (* ; "Yes, it is a quoted form we like") NAME))))
)
(PFI.HANDLE.PUTPROPS
(LAMBDA (EXPR) (* ; "Edited 7-Apr-88 11:09 by bvm") (PFI.MAYBE.NEW.PAGE EXPR) (LET ((NAME (CADR EXPR)) (PROP (CADDR EXPR)) TYPE) (* ; "See if PROP means something more specific than 'property'") (PFI.PRETTYPRINT EXPR (if (AND (LITATOM NAME) (SETQ TYPE (COND ((MEMB PROP MACROPROPS) (QUOTE MACRO)) (T (for PAIR in *PFI-PROPERTIES* when (EQ (CAR PAIR) PROP) do (* ; "Index it under this other type") (RETURN (CADR PAIR)) finally (* ; "Nothing better, so index it as having a property") (RETURN (QUOTE PROPERTY))))))) then (PFI.ADD.TO.INDEX NAME TYPE) (* ; "Yes, can name it this") NAME))))
)
(PFI.HANDLE./DECLAREDATATYPE
(LAMBDA (EXPR) (* ; "Edited 13-Apr-88 11:29 by bvm") (* ;; "No point in wasting space printing the entirely redundant list of field descriptors from (/DECLAREDATATYPE typename fieldspecs fielddescriptors len supertype)") (PFI.MAYBE.NEW.PAGE EXPR 2) (PFI.PRETTYPRINT (if (LISTP (CDR (LISTP (CDR (LISTP (CDR EXPR)))))) then (* ; "Well-formed--bash the third argument") (LIST* (pop EXPR) (pop EXPR) (pop EXPR) (LIST (QUOTE *) (QUOTE ;;) "---field descriptor list elided by lister---") (CDR EXPR)) else EXPR) NIL T))
)
(PFI.HANDLE.*
(LAMBDA (EXPR) (* ; "Edited 7-Apr-88 12:38 by bvm") (* ;; "Handle * comments found at top level. Turn single-semis into double semis so that they print at the left. Save all comments until the next non-comment so we can achieve some locality.") (LET* ((NSEMIS (SEMI-COLON-COMMENT-P EXPR)) (LINEGUESS (+ (CL:CEILING (STRINGWIDTH (if NSEMIS then (CADDR EXPR) else (CDR EXPR)) *STANDARD-OUTPUT*) (TIMES (- (DSPRIGHTMARGIN) (DSPLEFTMARGIN)) 0.9)) (if (AND NSEMIS (< NSEMIS 3)) then 1 else 2)))) (CASE NSEMIS (1 (* ; "Make it 2 semis") (SETQ EXPR (LIST* (QUOTE *) (QUOTE ;;) (CDDR EXPR)))) ((NIL) (* ; "Interlisp style") (if (NLISTP (CDR EXPR)) elseif (AND (NULL (CDDR EXPR)) (STRINGP (CADR EXPR))) then (* ; "Body is a string, so can print with superior semi-colon printer") (SETQ EXPR (LIST (QUOTE *) (QUOTE ;;) (CADR EXPR))) elseif (NEQ (CADR EXPR) COMMENTFLG) then (* ; "Turn single * into double star so it prints centered") (SETQ EXPR (LIST* (QUOTE *) (QUOTE *) (CDR EXPR)))))) (* ;; "Now don't print the comment yet, since we'd like it to attach to what follows") (if *PFI-PENDING-COMMENTS* then (add (CAR *PFI-PENDING-COMMENTS*) LINEGUESS) (NCONC1 *PFI-PENDING-COMMENTS* EXPR) else (SETQ *PFI-PENDING-COMMENTS* (LIST LINEGUESS EXPR)))))
)
(PFI.PRINT.COMMENTS
(LAMBDA (EXPR) (* ; "Edited 7-Apr-88 12:27 by bvm") (* ;; "Print any pending comments we have in preparation of printing EXPR. We want to print comments on same page as EXPR, so guess EXPR's size first. This is not perfect, since a handler might end up printing things differently, but it's probably not worse than default handling.") (TERPRI) (DESTRUCTURING-BIND (LINES . BODIES) *PFI-PENDING-COMMENTS* (if (NOT (DISPLAYSTREAMP *STANDARD-OUTPUT*)) then (LET ((REMAINING (PFI.LINES.REMAINING))) (if (OR (>= LINES REMAINING) (AND (< REMAINING *PFI-MAX-WASTED-LINES*) (< REMAINING (+ (PFI.ESTIMATE.SIZE EXPR) LINES)))) then (* ; "put it on a new page") (DSPNEWPAGE)))) (for B in BODIES do (PRINTDEF B T T) (if (> (DSPXPOSITION) (DSPLEFTMARGIN)) then (* ; "Go to new line for next comment. Usually this has already been done") (TERPRI))) (SETQ *PFI-PENDING-COMMENTS* NIL)))
)
(PFI.HANDLE.FILEMAP
(LAMBDA (EXPR) (* ; "Edited 31-Mar-88 15:28 by bvm") (* ;; "Only get here from declare: previewer (during SEE), since declare: expression handler filters out the whole thing.") (PFI.PRETTYPRINT (LIST (QUOTE *) (QUOTE ;;) "---Filemap elided by lister---") NIL T))
)
(PFI.HANDLE.PACKAGE
(LAMBDA (EXPR) (* ; "Edited 23-Apr-88 16:38 by bvm") (* ;; "Handler for package-related functions, such as in-package, import, export, etc. Eval the form so that the package environment is set correctly for what follows.") (CL:EVAL EXPR) (TERPRI) (PFI.PRETTYPRINT EXPR NIL T))
)
)
(* ; "Previewers")
(DEFINEQ
(PFI.PREVIEW.DECLARE
(LAMBDA (FN) (* ; "Edited 1-Apr-88 11:27 by bvm") (* ;; "Handle (DECLARE: tags coms ...) one piece at a time") (TERPRI) (PRIN1 "(") (PRIN2 FN) (bind STARTOFLINE NEXT until (EQ (SKIPSEPRCODES) (CHARCODE ")")) do (if (NLISTP (SETQ NEXT (READ))) then (* ; "Print the declare tags (and the declare: itself) all on one line, boringly") (if STARTOFLINE then (SETQ STARTOFLINE NIL) else (SPACES 1)) (PRIN2 NEXT) else (* ; "Have an interesting com") (if (NOT STARTOFLINE) then (TERPRI) (* ; "Start expressions on new line") (SETQ STARTOFLINE T)) (PFI.HANDLE.EXPR NEXT)) finally (READCCODE) (* ; "Eat the closing paren") (PRIN1 ")") (TERPRI)))
)
(PFI.PREVIEW.DEFINEQ
(LAMBDA (FN) (* ; "Edited 8-Apr-88 16:38 by bvm") (* ;; "Handle (DEFINEQ (fn1 . def) (fn2 . def) ...) one piece at a time") (TERPRI) (PRIN1 "(") (PRINT FN) (until (EQ (SKIPSEPRCODES) (CHARCODE ")")) do (PFI.PRINT.LAMBDA (READ))) (READCCODE) (* ; "Consume the paren") (PRIN1 ")") (TERPRI))
)
)
(* ; "Printing the index")
(DEFINEQ
(PFI.PRINT.INDEX
(LAMBDA (CRDATE) (* ; "Edited 16-May-88 15:48 by bvm") (* ;; "Compute the indices from the entries we have accumulated, print them, and return them (for multifileindex)") (LET ((LASTPAGE *PFI-PAGE-COUNT*) (*PFI-ITEM* :INDEX)) (LET ((*PFI-TITLE* NIL)) (* ; "Leave off the heading on the first index page, since it is intended to be the cover page--will have the title centered.") (DSPNEWPAGE) (COND ((AND *PFI-TWO-SIDED* (ODDP LASTPAGE)) (* ; "Ensure that the index will not be on the back-side of a two-sided listing") (DSPNEWPAGE)))) (PROGN (* ; "Print title.") (PFI.CENTER.PRINT (LIST *PFI-TITLE* CRDATE) T) (PFI.CENTER.PRINT (CONCAT "-- Listed on " (DATE) " --"))) (LET ((LINESPERPAGE (PFI.LINES.REMAINING)) (INDICES (PFI.CONDENSE.INDEX *PFI-LOCATIONS* LASTPAGE))) (PFI.PRINT.INDICES (APPEND INDICES) LINESPERPAGE) INDICES)))
)
(PFI.CONDENSE.INDEX
(LAMBDA (TRIPLES LASTPAGE) (* ; "Edited 12-May-88 13:07 by bvm") (* ;; "Condense TRIPLES into a set of indices, one per type. Each element is of the form (type name page), while the resulting indices are of the form (type entries . shape), with each entry looking like (name . pagenumbers). LASTPAGE is maximum page number (for gauging space).") (LET (*PFI-INDEX-ALIST* INDEX OLDNAME) (* ; "*PFI-INDEX-ALIST* is special so filters can look up entries") (for TRIP in TRIPLES do (* ; "Distribute to the correct type") (COND ((NULL (SETQ INDEX (ASSOC (CAR TRIP) *PFI-INDEX-ALIST*))) (push *PFI-INDEX-ALIST* (SETQ INDEX (LIST (CAR TRIP)))))) (COND ((SETQ OLDNAME (ASSOC (CADR TRIP) INDEX)) (* ; "Duplicate entry, so add a page number") (RPLACD OLDNAME (SORT (UNION (CDDR TRIP) (CDR OLDNAME))))) (T (push (CDR INDEX) (CDR TRIP))))) (* ;; "Now remove redundancies") (for TYPEPAIR in *PFI-INDEX-ALIST* bind FILTERS when (SETQ FILTERS (for FILTER in *PFI-FILTERS* collect (CDR FILTER) when (EQ (CAR FILTER) (CAR TYPEPAIR)))) do (* ; "Each filter is either a type name or a list whose car is a function") (RPLACD TYPEPAIR (for PAIR in (CDR TYPEPAIR) collect PAIR unless (for F in FILTERS thereis (COND ((NLISTP F) (* ; "Name exists as another type") (PFI.LOOKUP.NAME (CAR PAIR) F)) (T (CL:FUNCALL (CAR F) PAIR))))))) (PFI.SORT.INDICES (for TYPEPAIR in *PFI-INDEX-ALIST* when (CDR TYPEPAIR) collect (* ;; "Sort them and lay them out, changing format to (type entries . shape). Shape = (#rows #columns colwidth). WHEN is because filters could have removed everyone from a type.") (RPLACD TYPEPAIR (CONS (SORT (CDR TYPEPAIR) (FUNCTION (LAMBDA (X Y) (* ; "Sort case-insensitively by CAR") (ALPHORDER (CAR X) (CAR Y) UPPERCASEARRAY)))) (PFI.COMPUTE.INDEX.SHAPE (CDR TYPEPAIR) LASTPAGE)))))))
)
(PFI.SORT.INDICES
(LAMBDA (INDICES) (* ; "Edited 12-May-88 12:37 by bvm") (* ;; "INDICES is a list of (TYPE INDEXPAIRS . SHAPE). Sort them into a preferred order of printing.") (if (NULL (CDR INDICES)) then INDICES else (LET ((RESULT (for X in INDICES bind PRIORITY when (SETQ PRIORITY (CL:POSITION (CAR X) *PFI-INDEX-ORDER*)) collect (* ; "Gather up the types that the user-specified order handles") (CONS PRIORITY X)))) (if RESULT then (* ; "Sort them by priority") (SETQ RESULT (MAPCAR (SORT RESULT (FUNCTION (LAMBDA (X Y) (< (CAR X) (CAR Y))))) (FUNCTION CDR))) (* ; "Then remove them from the master list") (SETQ INDICES (CL:SET-DIFFERENCE INDICES RESULT))) (* ;; "Finally, sort remaining indices by decreasing size to facilitate indexer's selection. Leave a marker in between so we can tell the difference between required order and optional.") (NCONC RESULT (LIST T) (SORT INDICES (FUNCTION (LAMBDA (X Y) (LET ((ROWDIF (- (CADDR X) (CADDR Y)))) (if (> ROWDIF 0) then (* ; "X has more rows than Y") T elseif (EQ ROWDIF 0) then (* ; "If same number of rows, go for more items") (> (LENGTH (CADR X)) (LENGTH (CADR Y))))))))))))
)
(PFI.COMPUTE.INDEX.SHAPE
(LAMBDA (INDEXPAIRS MAXINDEXNO) (* ; "Edited 11-May-88 19:06 by bvm") (* ;; "Figures out how to lay out INDEXPAIRS, given that the largest possible page number is MAXINDEXNO. Returns a list (nrows ncolumns colwidth).") (LET ((INDEXNOWIDTH (AND MAXINDEXNO (COND ((< MAXINDEXNO 10) 1) ((< MAXINDEXNO 100) 2) (T (NCHARS MAXINDEXNO))))) (INDEXLEN (LENGTH INDEXPAIRS)) NROWS NCOLUMNS WIDTH) (SETQ WIDTH (+ (for PAIR in INDEXPAIRS largest (+ (NCHARS (CAR PAIR) T) (COND ((CDDR PAIR) (* ;; "Multiple page nos--turn into printed rep") (PROG1 (NCHARS (CAR (RPLACA (CDR PAIR) (CONCATLIST (CDR (for P in (CDR PAIR) join (LIST "," P))))))) (RPLACD (CDR PAIR) NIL))) ((STRINGP (CADR PAIR)) (* ; "It's already a string") (NCHARS (CADR PAIR))) (T INDEXNOWIDTH))) finally (RETURN $$EXTREME)) 1)) (* ; "WIDTH is the widest any entry gets: name plus page numbers. Conservative in that we assume page numbers can take up as much space as the largest") (SETQ NCOLUMNS (MAX 1 (MIN INDEXLEN (IQUOTIENT (LINELENGTH) (+ WIDTH 2))))) (* ; "Number of columns that fit if you allow 2 spaces between columns") (SETQ NROWS (CL:CEILING INDEXLEN NCOLUMNS)) (* ;; "Finally recompute NCOLUMNS. This might reduce the number of columns if all the items, printed in NROWS rows, take fewer columns than originally allocated. E.g. 11 items in 5 cols take 3 rows, but in 3 rows you only need 4 cols to print 11 items.") (LIST NROWS (CL:CEILING INDEXLEN NROWS) WIDTH)))
)
(PFI.PRINT.INDICES
(LAMBDA (INDICES LINESPERPAGE) (* ; "Edited 16-May-88 15:45 by bvm") (* ;; "Print a set of INDICES. LINESPERPAGE is number of lines we expect to fit per page not counting page headers.") (PROG ((HALFPAGE (IQUOTIENT LINESPERPAGE 2)) (LINELEN (LINELENGTH)) (SPACEWIDTH (CHARWIDTH (CHARCODE X) *STANDARD-OUTPUT*)) (LINESREMAINING (- (PFI.LINES.REMAINING) 2)) ITEM FREECHOICE PREVITEM) NEWPAGE (* ;; "At this point we are at the top of a page") (TERPRI) (PFI.INDEX.BREAK) TOP (if (NULL INDICES) then (* ; "Done") (RETURN) elseif (NULL FREECHOICE) then (* ; "Have to take the first batch in order") (SETQ ITEM (pop INDICES)) (if (EQ ITEM T) then (* ; "Marks start of optional order. Items from here on are sorted by decreasing size, but we can print them in any order we want") (SETQ FREECHOICE T) (GO TOP)) elseif (SETQ ITEM (find X in INDICES suchthat (<= (CADDR X) (- LINESREMAINING 5)))) then (* ; "Found an item that fits") (SETQ INDICES (DREMOVE ITEM INDICES)) elseif (OR (> LINESREMAINING HALFPAGE) (> (+ (CADDR (CAR (LAST INDICES))) 7) LINESPERPAGE)) then (* ; "Print something here anyway, since we're either less than halfway down the page, or the smallest index doesn't fit on a page") (SETQ ITEM (pop INDICES)) else (* ; "Start a new page and try again") (GO STARTNEWPAGE)) (DESTRUCTURING-BIND (TYPE INDEXPAIRS NROWS NCOLUMNS COLWIDTH) ITEM (PROG ((NROWSREMAINING NROWS) LASTITEM SPACING) (if (AND (EQ NROWS 1) PREVITEM (<= COLWIDTH (CADR PREVITEM)) (<= NCOLUMNS (CAR PREVITEM))) then (* ; "There's only one row, so it would be nice if it could line up with another index. Can do this if this column width is not larger than previous. PREVITEM = (ncolumns colwidth spacing ...)") (SETQ COLWIDTH (CADR PREVITEM)) (SETQ SPACING (CADDR PREVITEM)) else (LET ((NC NCOLUMNS)) (if (OR (NEQ NC 1) (if (< COLWIDTH (IQUOTIENT LINELEN 2)) then (* ; "format as if 2 columns") (SETQ NC 2) else (* ; "Too wide for 2 columns, so use whole width") (SETQ COLWIDTH LINELEN) (SETQ SPACING 0) NIL)) then (* ; "Divide the excess space up between dots and intercolumn spacing") (SETQ COLWIDTH (MIN (PROGN (* ; "Add to COLWIDTH half the excess space") (+ COLWIDTH (IQUOTIENT (- LINELEN (TIMES (+ COLWIDTH 2) NC)) 2))) (PROGN (* ; "Allow 2 spaces between columns") (- (IQUOTIENT LINELEN NC) 2)))) (SETQ SPACING (IQUOTIENT (- (DSPRIGHTMARGIN) (DSPLEFTMARGIN) (TIMES COLWIDTH NC SPACEWIDTH)) (SUB1 NC)))) (SETQ PREVITEM (LIST NC COLWIDTH SPACING)))) (if (AND (> (+ NROWS 5) LINESREMAINING) (< LINESREMAINING HALFPAGE) (<= (+ NROWS 8) LINESPERPAGE)) then (* ;; "This index doesn't fit on the page, we've filled less than half the page, and the index would fit starting on a new page. Each index takes 5 additional lines: blank, heading, blank <items> blank breakline. If on a new page it would take 3 more (blank breakline blank).") (DSPNEWPAGE) (* ; "Start new page") (TERPRI) (* ; "Make top breaklines line up on all index pages") (PFI.INDEX.BREAK) (SETQ LINESREMAINING (- LINESPERPAGE 2))) (TERPRI) (PFI.CENTER.PRINT (CONCAT (if (AND (EQ (NTHCHARCODE TYPE -1) (CHARCODE S)) (NEQ (NTHCHARCODE TYPE -2) (CHARCODE S)) (NOT (STRPOS "IE" TYPE -3))) then (* ; "Turn plural type into singular. Second clause filters out DROSS and CANDIES.") (SUBSTRING TYPE 1 -2) else TYPE) " INDEX") T) (CHANGEFONT DEFAULTFONT) (TERPRI) (SETQ LINESREMAINING (- LINESREMAINING 3)) (while INDEXPAIRS do (SETQ NROWS (IMIN NROWSREMAINING (- LINESREMAINING 1))) (for ROW from 1 to NROWS bind NEXTINDEX do (SETQ NEXTINDEX ROW) (for COLUMN from 1 to NCOLUMNS do (COND ((SETQ LASTITEM (FNTH INDEXPAIRS NEXTINDEX)) (DESTRUCTURING-BIND (LABEL PAGENO) (CAR LASTITEM) (PRIN2 LABEL) (SPACES 1) (FRPTQ (- COLWIDTH (ADD1 (NCHARS LABEL T)) (NCHARS PAGENO)) (\OUTCHAR *STANDARD-OUTPUT* (CHARCODE %.))) (PRIN1 PAGENO) (COND ((NEQ COLUMN NCOLUMNS) (RELMOVETO SPACING 0)))))) (add NEXTINDEX NROWS)) (TERPRI)) (COND ((SETQ INDEXPAIRS (CDR LASTITEM)) (DSPNEWPAGE) (TERPRI) (SETQ LINESREMAINING (- LINESPERPAGE 1)) (SETQ NROWSREMAINING (ADD1 (IQUOTIENT (LENGTH INDEXPAIRS) NCOLUMNS)))) (T (SETQ LINESREMAINING (- LINESREMAINING NROWS))))) (TERPRI) (PFI.INDEX.BREAK T) (if (NULL INDICES) then (* ; "Done") (RETURN) elseif (< (SETQ LINESREMAINING (- LINESREMAINING 2)) 6) then (* ; "No room left here, go to new page. ") (GO STARTNEWPAGE) else (* ; "T in PFI.INDEX.BREAK told it to hold the terpri") (TERPRI)))) (GO TOP) STARTNEWPAGE (DSPNEWPAGE) (SETQ LINESREMAINING (- LINESPERPAGE 2)) (* ; "Account for the break line and blank line we are about to print") (GO NEWPAGE)))
)
(PFI.CENTER.PRINT
(LAMBDA (STR BOLDFLG) (* ; "Edited 30-Mar-88 14:31 by bvm") (LET ((LMAR (DSPLEFTMARGIN)) GAP) (if BOLDFLG then (CHANGEFONT BOLDFONT)) (DSPXPOSITION (+ LMAR (IQUOTIENT (- (DSPRIGHTMARGIN) LMAR (if (LISTP STR) then (+ (TIMES (SUB1 (LENGTH STR)) (SETQ GAP (TIMES (DSPSCALE) 16))) (for X in STR sum (STRINGWIDTH X *STANDARD-OUTPUT*))) else (STRINGWIDTH STR *STANDARD-OUTPUT*))) 2))) (if (LISTP STR) then (for TAIL on STR do (PRIN3 (CAR TAIL)) (AND (CDR TAIL) (RELMOVETO GAP 0))) else (PRIN3 STR)) (if BOLDFLG then (CHANGEFONT DEFAULTFONT)) (TERPRI)))
)
(PFI.INDEX.BREAK
(LAMBDA (NOTERPRI) (* ; "Edited 11-Apr-88 16:47 by bvm") (* ;; "Draw the line separating one type index from the next. NOTERPRI suppresses the new line") (LET* ((OLDY (DSPYPOSITION)) (Y (+ (- OLDY (FONTPROP *STANDARD-OUTPUT* (QUOTE DESCENT))) (IQUOTIENT (- (DSPLINEFEED)) 2)))) (* ; "Draw a horizontal line centered on this line") (DRAWLINE (DSPLEFTMARGIN) Y (DSPRIGHTMARGIN) Y (DSPSCALE)) (DSPYPOSITION OLDY)) (OR NOTERPRI (TERPRI)))
)
(PFI.LOOKUP.NAME
(LAMBDA (NAME TYPE) (* ; "Edited 25-Mar-88 14:07 by bvm") (ASSOC NAME (CDR (ASSOC TYPE *PFI-INDEX-ALIST*))))
)
)
(DEFINEQ
(PFI.ADD.TO.INDEX
(LAMBDA (NAME TYPE/ENTRY) (* ; "Edited 6-Apr-88 16:15 by bvm") (* ;; "Add to the index an entry for NAME of type TYPE/ENTRY. TYPE/ENTRY can be an element of *pfi-types*, in which case we use its type name component.") (if (NEQ *PFI-LOCATIONS* :NONE) then (push *PFI-LOCATIONS* (LIST (if (NLISTP TYPE/ENTRY) then (* ; "the type directly") TYPE/ENTRY else (* ; "a types triple") (LET ((TYPE (fetch (PFITYPE NAME) of TYPE/ENTRY))) (OR (CAR (LISTP TYPE)) TYPE))) NAME *PFI-PAGE-COUNT*))))
)
(PFI.VARNAME
(LAMBDA (EXPR) (* ; "Edited 24-Mar-88 16:09 by bvm") (* ;;; "Called for expressions whose car is one of RPAQ, RPAQQ, RPAQ?, ADDTOVAR. Filters after the fact will remove duplications with other variable types") (LET ((NAME (CADR EXPR))) (* ; "Ignore compiler-internal vars") (AND (LITATOM NAME) (NEQ NAME T) (NOT (FMEMB NAME (QUOTE (GLOBALVARS SPECVARS LOCALVARS NLAMA NLAML LAMA)))) NAME)))
)
(PFI.CONSTANTNAMES
(LAMBDA (EXPR) (* ; "Edited 11-Apr-88 14:24 by bvm") (* ;;; "Called when expression is (CONSTANTS --) -- return all elements (or CAR of element when it's a pair) as type CONSTANTS") (CONS (QUOTE CONSTANTS) (for X in (CDR EXPR) collect (COND ((LISTP X) (CAR X)) (T X)))))
)
)
(* ; "Combined listings")
(DEFINEQ
(MULTIFILEINDEX
(LAMBDA (FILES PRINTOPTIONS) (* ; "Edited 20-May-88 14:08 by bvm") (* ;; "Produce a pretty file index listing for each of FILES, plus a master index for the set") (LET ((*UPPER-CASE-FILE-NAMES* NIL)) (SETQ FILES (for F inside FILES join (if (STRPOS "*" F) then (* ; "Enumerate a pattern--default extension to null and version to highest") (DIRECTORY (DIRECTORY.FILL.PATTERN F "" "")) elseif (LISTP F) then (* ; "Hack that says don't print these") (for FL in F collect (LIST (OR (FINDFILE FL T) (CL:ERROR (QUOTE XCL:FILE-NOT-FOUND) :PATHNAME FL)))) else (LIST (OR (FINDFILE F T) (CL:ERROR (QUOTE XCL:FILE-NOT-FOUND) :PATHNAME F)))))) (COND (*PFI-DONT-SPAWN* (MULTIFILEINDEX1 FILES PRINTOPTIONS)) (T (PFI.ENQUEUE (LIST (FUNCTION MULTIFILEINDEX1) FILES PRINTOPTIONS)) FILES))))
)
(MULTIFILEINDEX1
(LAMBDA (FILES PRINTOPTIONS) (* ; "Edited 19-May-88 12:35 by bvm") (* ;; "Pretty list each of the files in FILES, followed by master index") (LET ((CONSECUTIVE (LISTGET PRINTOPTIONS :CONSECUTIVE)) INDICES OPTIONS NOTPRINTED) (SETQ PRINTOPTIONS (LIST* (QUOTE MULTIFILEINDEX) T PRINTOPTIONS)) (* ; "Our own option") (for TAIL on FILES as I from 1 do (* ; "Print and gather indices for all but last file") (SETQ OPTIONS (if CONSECUTIVE then (* ; "Tell it which page to start on") (LIST* :FIRSTPAGE (if INDICES then (* ; "One past the end of the last one") (ADD1 (CADDR (CAAR INDICES))) else 1) PRINTOPTIONS) else (* ; "Tell it which part to work on") (LIST* :PART I PRINTOPTIONS))) (push INDICES (if (SETQ NOTPRINTED (LISTP (CAR TAIL))) then (* ; "Go thru the motions but don't print it") (PRETTYFILEINDEX (CAAR TAIL) (LIST* :DONTPRINT T OPTIONS)) else (if (NULL (CDR TAIL)) then (* ; "When printing last file, send along all the indices for a combined listing") (RPLACA (CDR PRINTOPTIONS) (REVERSE INDICES))) (PRETTYFILEINDEX (CAR TAIL) OPTIONS)))) (IF NOTPRINTED THEN (* ; "The last file wasn't printed, so have to make index on our own") (LET* ((*PFI-TWO-SIDED* (EQ (OR (LISTGET PRINTOPTIONS (QUOTE %#SIDES)) EMPRESS#SIDES) 2)) (*STANDARD-OUTPUT* (PFI.MAKE.LPT.STREAM (LIST* (QUOTE DOCUMENT.NAME) (QUOTE INDEX) PRINTOPTIONS)))) (CL:UNWIND-PROTECT (PFI.PRINT.MULTI.INDEX (REVERSE INDICES) PRINTOPTIONS) (CLOSEF *STANDARD-OUTPUT*))))))
)
(PFI.PRINT.MULTI.INDEX
(LAMBDA (INDEXENTRIES PRINTOPTIONS) (* ; "Edited 19-May-88 17:37 by bvm") (* ;; "Print the master index for a set of indexed files. INDEXENTRIES has one element per file, each of the form ((filename creationdate lastpage# env) . indices), the indices having come out of PFI.PRINT.INDEX") (LET ((MAXNAME 0) (MAXDATE 0) (CONSECUTIVE (LISTGET PRINTOPTIONS :CONSECUTIVE)) (ENV (LISTGET PRINTOPTIONS :ENVIRONMENT)) BESTPACKAGE BESTREADTABLE MAXPAGE# MASTERINDICES LINESPERPAGE NAMES&DATES) (STREAMPROP *STANDARD-OUTPUT* (QUOTE AFTERNEWPAGEFN) NIL) (* ; "No more header hacking") (IF (NEQ (LISTGET PRINTOPTIONS (QUOTE MULTIFILEINDEX)) T) THEN (* ; "If it was T, then we must be called from MULTFILEINDEX1 to print only the index, so are on the first page right now.") (DSPNEWPAGE) (* ; "Start a new page") (if (AND *PFI-TWO-SIDED* (ODDP *PFI-PAGE-COUNT*)) then (* ; "Ensure that the master index will not be on the back-side of a two-sided listing") (DSPNEWPAGE))) (SETQ LINESPERPAGE (PFI.LINES.REMAINING)) (PFI.CENTER.PRINT (CONCAT "Master index generated on " (DATE (DATEFORMAT NO.SECONDS)))) (TERPRI) (CHANGEFONT BOLDFONT) (for PAIR in INDEXENTRIES as I from 1 bind PREFIX MASTERENTRY FILEINFO E TEM do (push NAMES&DATES (SETQ FILEINFO (CAR PAIR))) (* ; "FILEINFO = (name date last# env)") (SETQ MAXNAME (MAX MAXNAME (STRINGWIDTH (POP FILEINFO) *STANDARD-OUTPUT*))) (SETQ MAXDATE (MAX MAXDATE (STRINGWIDTH (POP FILEINFO) *STANDARD-OUTPUT*))) (SETQ MAXPAGE# (POP FILEINFO)) (if (NOT ENV) then (SETQ E (CAR FILEINFO)) (if (SETQ TEM (ASSOC (fetch REPACKAGE of E) BESTPACKAGE)) then (add (CDR TEM) 1) else (push BESTPACKAGE (CONS (fetch REPACKAGE of E) 1))) (if (SETQ TEM (ASSOC (fetch REREADTABLE of E) BESTREADTABLE)) then (add (CDR TEM) 1) else (push BESTREADTABLE (CONS (fetch REREADTABLE of E) 1)))) (if (NOT CONSECUTIVE) then (* ; "This gets in front of all page#s") (SETQ PREFIX (CONCAT I "-"))) (for INDEX in (CDR PAIR) unless (EQ INDEX T) do (* ; "INDEX = (type pairs . shape). T is a separator that we no longer care about.") (if (NOT CONSECUTIVE) then (* ; "Prefix page numbers with file number") (for INDEXITEM in (CADR INDEX) do (RPLACA (CDR INDEXITEM) (CONCAT PREFIX (CADR INDEXITEM))))) (if (NULL (SETQ MASTERENTRY (ASSOC (CAR INDEX) MASTERINDICES))) then (* ; "Haven't seen any yet, just store it") (push MASTERINDICES (CONS (CAR INDEX) (CADR INDEX))) else (* ; "Merge with what's there") (RPLACD MASTERENTRY (PFI.MERGE.INDICES (CDR MASTERENTRY) (CADR INDEX)))))) (LET* ((LEFT (DSPLEFTMARGIN)) (FATSPACE (TIMES (DSPSCALE) 8)) (RANGEWIDTH (if CONSECUTIVE then (+ (STRINGWIDTH "[-]" *STANDARD-OUTPUT*) (TIMES (+ FATSPACE (STRINGWIDTH MAXPAGE# *STANDARD-OUTPUT*)) 2)) else (* ; "No page ranges to print") FATSPACE)) (DIGITSWIDTH (STRINGWIDTH "99." *STANDARD-OUTPUT*)) (MAXWIDTH (+ DIGITSWIDTH RANGEWIDTH MAXNAME FATSPACE FATSPACE MAXDATE)) (LINEWIDTH (- (DSPRIGHTMARGIN) LEFT)) (LASTPAGE 0) TAB1 TAB2 TAB3 TEM) (if (< MAXWIDTH LINEWIDTH) then (SETQ TAB1 (+ LEFT DIGITSWIDTH (IQUOTIENT (- LINEWIDTH MAXWIDTH) 2))) (* ; "Digit flush against here") (SETQ TAB2 (+ TAB1 RANGEWIDTH)) (* ; "Name starts here") (SETQ TAB3 (+ TAB2 MAXNAME FATSPACE FATSPACE MAXDATE)) (* ; "Date flush right here")) (for N&D in (REVERSE NAMES&DATES) as I from 1 do (CHANGEFONT BOLDFONT) (SETQ TEM (CONCAT I ".")) (if TAB1 then (DSPXPOSITION (- TAB1 (STRINGWIDTH TEM *STANDARD-OUTPUT*)))) (PRIN3 TEM) (if CONSECUTIVE then (SETQ TEM (CONCAT "[" (LOGOR (+ LASTPAGE 1) (if *PFI-TWO-SIDED* then 1 else 0)) "-" (SETQ LASTPAGE (CADDR N&D)) "]")) (if TAB2 then (DSPXPOSITION (+ TAB1 (IQUOTIENT (- RANGEWIDTH (STRINGWIDTH TEM *STANDARD-OUTPUT*)) 2)))) (PRIN3 TEM)) (if TAB2 then (DSPXPOSITION TAB2) else (RELMOVETO FATSPACE 0)) (PRIN3 (CAR N&D)) (if TAB3 then (DSPXPOSITION (- TAB3 (STRINGWIDTH (CADR N&D) *STANDARD-OUTPUT*))) else (RELMOVETO FATSPACE 0)) (PRIN3 (CADR N&D)) (CHANGEFONT DEFAULTFONT) (TERPRI))) (for TYPEPAIR in MASTERINDICES do (* ;; "Now that each index is complete, turn (type . indices) into (type indices . shape)") (RPLACD TYPEPAIR (CONS (CDR TYPEPAIR) (PFI.COMPUTE.INDEX.SHAPE (CDR TYPEPAIR) MAXPAGE#)))) (if (NOT ENV) then (SETQ BESTPACKAGE (PFI.CHOOSE.BEST BESTPACKAGE)) (SETQ BESTREADTABLE (PFI.CHOOSE.BEST BESTREADTABLE)) elseif (TYPENAMEP ENV (QUOTE READER-ENVIRONMENT)) then (SETQ BESTPACKAGE (fetch REPACKAGE of ENV)) (SETQ BESTREADTABLE (fetch REREADTABLE of ENV)) else (SETQ BESTPACKAGE (LISTGET ENV :PACKAGE)) (if (LISTP BESTPACKAGE) then (SETQ BESTPACKAGE (EVAL BESTPACKAGE))) (if (NOT (OR (CL:PACKAGEP BESTPACKAGE) (SETQ BESTPACKAGE (CL:FIND-PACKAGE BESTPACKAGE)))) then (SETQ BESTPACKAGE (CL:ERROR "No valid package in environment ~S" ENV))) (SETQ BESTREADTABLE (LISTGET ENV :READTABLE)) (if (LISTP BESTREADTABLE) then (SETQ BESTREADTABLE (EVAL BESTREADTABLE))) (if (NOT (OR (READTABLEP BESTREADTABLE) (SETQ BESTREADTABLE (FIND-READTABLE BESTREADTABLE)))) then (SETQ BESTREADTABLE (CL:ERROR "No valid read table in environment ~S" ENV)))) (LET ((*PACKAGE* BESTPACKAGE) (*READTABLE* BESTREADTABLE)) (PFI.PRINT.INDICES (PFI.SORT.INDICES MASTERINDICES) LINESPERPAGE))))
)
(PFI.CHOOSE.BEST
(LAMBDA (LST) (* ; "Edited 19-May-88 12:30 by bvm") (* ;; "Return the car of the element in ALIST having the largest vote, or first such if a tie.") (CAAR (CL:STABLE-SORT LST (QUOTE >) :KEY (QUOTE CDR))))
)
(PFI.MERGE.INDICES
(LAMBDA (MASTER NEWINDEX) (* ; "Edited 12-May-88 14:25 by bvm") (* ;; "Merge two lists of index entries. Each is a list (name location). In case of collision, it is known that MASTER locations appear before NEWINDEX locations") (NCONC (while (AND NEWINDEX MASTER) collect (SELECTQ (ALPHORDER (CAAR MASTER) (CAAR NEWINDEX) UPPERCASEARRAY) (EQUAL (* ; "Same name in two places, so merge the locations") (RPLACA (CDAR MASTER) (CONCAT (CADAR MASTER) "," (CADR (pop NEWINDEX)))) (pop MASTER)) (LESSP (* ; "Master less, so take it first") (pop MASTER)) (PROGN (* ; "NEWINDEX less, so take it") (pop NEWINDEX)))) (PROGN (* ; "Plus whichever, if either, is left over") (OR NEWINDEX MASTER))))
)
)
(* ; "Hooks for seeing files pretty elsewhere")
(DEFINEQ
(PFI.MAYBE.SEE.PRETTY
(LAMBDA (FROMFILE TOFILE) (* ; "Edited 1-Apr-88 11:23 by bvm") (* ;; "Replaces COPYALLBYTES and PFCOPYBYTES in various forms of SEE that want to see a whole file") (RESETLST (LET ((*UPPER-CASE-FILE-NAMES* NIL) OUTSTREAM INSTREAM) (if (OR (NULL *PRINT-PRETTY-FROM-FILES*) (NULL (SETQ OUTSTREAM (DISPLAYP TOFILE)))) then (* ; "Not a display window, or don't want prettyprinting") (if (STREAMP FROMFILE) then (* ; "Wanted PFCOPYBYTES") (PFCOPYBYTES FROMFILE TOFILE) else (COPYALLBYTES FROMFILE TOFILE)) else (if (NOT (SETQ INSTREAM (STREAMP FROMFILE))) then (RESETSAVE NIL (LIST (QUOTE CLOSEF) (SETQ INSTREAM (OPENSTREAM FROMFILE (QUOTE INPUT) NIL (QUOTE ((SEQUENTIAL T)))))))) (* ;; "Open the file, try to prettyprint it. We get NIL back from PRETTYFILEINDEX if it's not a file manager file") (if (PRETTYFILEINDEX INSTREAM NIL OUTSTREAM T) else (PFCOPYBYTES INSTREAM OUTSTREAM) (FULLNAME INSTREAM))))))
)
(PFI.MAYBE.PP.DEFINITION
(LAMBDA (INSTREAM OUTSTREAM START END) (* ; "Edited 1-Apr-88 11:22 by bvm") (LET (ENV) (if (OR (NULL *PRINT-PRETTY-FROM-FILES*) (NOT (DISPLAYP OUTSTREAM)) (NULL (SETQ ENV (GET-ENVIRONMENT-AND-FILEMAP INSTREAM))) (WITH-READER-ENVIRONMENT ENV (SETFILEPTR INSTREAM START) (CL:MULTIPLE-VALUE-BIND (DEF CONDITION) (IGNORE-ERRORS (READ INSTREAM)) (LET ((*STANDARD-OUTPUT* (GETSTREAM OUTSTREAM (QUOTE OUTPUT)))) (if CONDITION then (CL:FORMAT T "[Failed to read because: ~A]" CONDITION) T else (PFI.PRINT.LAMBDA.BODY DEF) (TERPRI) NIL))))) then (* ;; "Punt to what we were called for in the first place") (PFCOPYBYTES INSTREAM OUTSTREAM START END))))
)
)
(RPAQ? *PRINT-PRETTY-FROM-FILES* T)
(* ; "Bitmap hack")
(DEFINEQ
(PFI.PRINT.BITMAP
(LAMBDA (BM STREAM) (* ; "Edited 14-Apr-88 12:44 by bvm") (* ;; "DEFPRINT function for bitmaps that displays the actual bitmap when going to an image stream.") (if (OR (NULL *PRINT-ARRAY*) (NULL *PRINT-PRETTY-BITMAPS*)) then (* ; "do the clunky way") (NON.PFI.PRINT.BITMAP BM STREAM) elseif (IMAGESTREAMP STREAM) then (PROG ((CURX (DSPXPOSITION NIL STREAM)) (CURY (DSPYPOSITION NIL STREAM)) (UNITS (DSPSCALE NIL STREAM)) (LINEHEIGHT (DSPLINEFEED NIL STREAM)) HEIGHT WIDTH MINX NLINESDOWN BOTTOM BMARG BELOWBASELINE SCALE RATIO) (if (NOT (AND CURX CURY UNITS LINEHEIGHT)) then (* ; "Stream doesn't really support it") (RETURN (NON.PFI.PRINT.BITMAP BM STREAM))) (SETQ HEIGHT (TIMES UNITS (BITMAPHEIGHT BM))) (SETQ WIDTH (TIMES UNITS (BITMAPWIDTH BM))) (SETQ BMARG (DSPBOTTOMMARGIN NIL STREAM)) (if (AND (NOT (DISPLAYSTREAMP STREAM)) (< (SETQ RATIO (MIN (FQUOTIENT (- (DSPRIGHTMARGIN NIL STREAM) (DSPLEFTMARGIN NIL STREAM)) (TIMES WIDTH 1.5)) (FQUOTIENT (- (DSPTOPMARGIN NIL STREAM) BMARG) (TIMES HEIGHT 1.5)))) 1.0)) then (* ; "It takes up more than 2/3 the page in some dimension. This code is tuned for Interpress.") (SETQ SCALE (if (> RATIO 0.75) then 0.75 elseif (> RATIO 0.5) then 0.5 elseif (> RATIO 0.25) then 0.25 else RATIO)) (SETQ HEIGHT (FIXR (TIMES SCALE HEIGHT))) (SETQ WIDTH (FIXR (TIMES SCALE WIDTH)))) (if (> CURX (SETQ MINX (- (DSPRIGHTMARGIN NIL STREAM) WIDTH))) then (* ; "Won't fit between here and margin, so start nwe line") (TERPRI STREAM) (SETQ CURX (MAX MINX 0)) (SETQ CURY (DSPYPOSITION NIL STREAM))) (SETQ BELOWBASELINE (MAX 0 (- HEIGHT (FONTPROP STREAM (QUOTE ASCENT))))) (if BMARG then (* ; "We know stream's bottom margin, so can be reasonable") (if (< (- CURY BELOWBASELINE) BMARG) then (* ; "Won't fit on page") (DSPNEWPAGE STREAM) (SETQ CURY (DSPYPOSITION NIL STREAM)) (SETQ *PFI-BITMAP-BASELINE* NIL)) else (* ; "Have to use silly terpri method") (SETQ NLINESDOWN (IQUOTIENT HEIGHT (SETQ LINEHEIGHT (- LINEHEIGHT)))) (to NLINESDOWN do (* ; "Do enough cr's so that we have space for bitmap. This might cause scrolling, for example") (TERPRI STREAM) finally (* ; "If this was display, terpri may have scrolled, and Y changed out from under us") (SETQ CURY (+ (DSPYPOSITION NIL STREAM) (TIMES NLINESDOWN LINEHEIGHT))))) (SETQ BOTTOM (- CURY BELOWBASELINE)) (* ; "BOTTOM computed so that bitmap top lines up with font top") (SCALEDBITBLT BM 0 0 STREAM CURX BOTTOM WIDTH HEIGHT (QUOTE INPUT) (QUOTE REPLACE) NIL NIL SCALE) (MOVETO (+ CURX WIDTH) (if (AND (< BOTTOM CURY) (EQ *PRINT-PRETTY-BITMAPS* (QUOTE PRETTYFILEINDEX)) *PFI-FUNNY-CHARS*) then (* ; "Don't move the baseline down, just remember it for when we hit end of line") (if (OR (NULL *PFI-BITMAP-BASELINE*) (< BOTTOM *PFI-BITMAP-BASELINE*)) then (* ; "Lower than before, or first time") (SETQ *PFI-BITMAP-BASELINE* BOTTOM) (if (NEQ (fetch (STREAM OUTCHARFN) of STREAM) (FUNCTION PFI.OUTCHARFN)) then (* ; "Also have to %"advise%" the outcharfn to notice terpri") (replace (STREAM OUTCHARFN) of STREAM with (FUNCTION PFI.OUTCHARFN)))) CURY else (* ; "Move baseline down to bitmap baseline") BOTTOM) STREAM) (RETURN T)) else (LET ((POS (AND (EQ *PRINT-PRETTY-BITMAPS* (QUOTE PRETTYFILEINDEX)) (PNAMESTREAMP STREAM) (STKPOS (QUOTE STRINGWIDTH)))) IMSTREAM) (if (AND POS (IMAGESTREAMP (SETQ IMSTREAM (STKEVAL POS (QUOTE *STANDARD-OUTPUT*) T)))) then (* ;; "Big kludge: This is somebody in the prettyprinter trying to figure out the width of the bitmap--fake them out by printing something about the width of the bitmap. IMSTREAM is the stream to which the real output will go. To be conservative, only do this under PRETTYFILEINDEX.") (RPTQ (CL:CEILING (TIMES (DSPSCALE NIL IMSTREAM) (BITMAPWIDTH BM)) (CHARWIDTH (CHARCODE X) IMSTREAM)) (\OUTCHAR STREAM (CHARCODE X))) T else (NON.PFI.PRINT.BITMAP BM STREAM)))))
)
)
(RPAQ? *PRINT-PRETTY-BITMAPS* T)
(RPAQ? *PFI-PRINTOPTIONS* (QUOTE (REGION (2540 1905 17780 24765))))
(RPAQ? *PFI-DONT-SPAWN*)
(RPAQ? *PFI-MAX-WASTED-LINES* 12)
(RPAQ? *PFI-CHARACTER-TRANSLATIONS* (QUOTE ((INTERPRESS (95 172) (96 169 FAMILY CLASSIC) (39 185 FAMILY CLASSIC)))))
(RPAQ? *PFI-INDEX-ORDER* (QUOTE (FUNCTIONS)))
(RPAQ? *PFI-DEFINER-PROPS* (LET ((*PACKAGE* (if (EQ MAKESYSNAME :LYRIC) then *INTERLISP-PACKAGE* else *KEYWORD-PACKAGE*))) (* ;; "Properties of definers changed between Lyric and Medley (yech).") (MAPCAR (QUOTE ("DEFINER-FOR" "DEFINED-BY" "DEFINITION-NAME")) (FUNCTION CL:INTERN))))
(RPAQ? \PFI.PROCESS.COMMANDS)
(RPAQ? \PFI.PROCESSLOCK (CREATE.MONITORLOCK "PRETTYFILEINDEX"))
(RPAQ? \PFI.PROCESS)
(* ;;
"These are just in case our afternewpagefn escapes our dynamic context. *PFI-TITLE* being NIL means we're outside prettyfileindex"
)
(RPAQ? *PFI-TITLE*)
(RPAQ? *PFI-PAGE-COUNT* 0)
(ADDTOVAR *PFI-TYPES* (ADVICE XCL:REINSTALL-ADVICE) (CONSTANTS CONSTANTS PFI.CONSTANTNAMES) (CONSTANTS CL:DEFCONSTANT) (COURIERPROGRAM COURIERPROGRAM) (DEFINERS DEFDEFINER) (I.S.OPR I.S.OPR) (MACRO DEFMACRO) (TEMPLATE SETTEMPLATE) (VARIABLES (RPAQ RPAQ? RPAQQ ADDTOVAR) PFI.VARNAME))
(ADDTOVAR *PFI-HANDLERS* (PUTPROPS . PFI.HANDLE.PUTPROPS) (DECLARE%: . PFI.HANDLE.DECLARE) (DEFINEQ . PFI.HANDLE.DEFINEQ) (PUTDEF . PFI.HANDLE.PUTDEF) (RPAQQ . PFI.HANDLE.RPAQQ) (DEFDEFINER . PFI.HANDLE.DEFDEFINER) (PRETTYCOMPRINT . NILL) (FILEMAP . PFI.HANDLE.FILEMAP) (* . PFI.HANDLE.*) (/DECLAREDATATYPE . PFI.HANDLE./DECLAREDATATYPE) (CL:IN-PACKAGE . PFI.HANDLE.PACKAGE) (CL:USE-PACKAGE . PFI.HANDLE.PACKAGE) (CL:SHADOW . PFI.HANDLE.PACKAGE) (CL:SHADOWING-IMPORT . PFI.HANDLE.PACKAGE) (IMPORT . PFI.HANDLE.PACKAGE) (EXPORT . PFI.HANDLE.PACKAGE) (CL:EVAL-WHEN . PFI.HANDLE.EVAL-WHEN))
(ADDTOVAR *PFI-PREVIEWERS* (DECLARE%: . PFI.PREVIEW.DECLARE) (DEFINEQ . PFI.PREVIEW.DEFINEQ))
(ADDTOVAR *PFI-PROPERTIES* (COPYRIGHT) (READVICE ADVICE))
(ADDTOVAR *PFI-FILTERS* (VARIABLES . CONSTANTS))
(* ; "Prettyprint augmentation to mimic system makefile dumping")
(DEFINEQ
(PUTPROPS.PRETTYPRINT
(LAMBDA (EXPR) (* ; "Edited 30-Mar-88 11:35 by bvm") (* ;; "does prettyprinting for PUTPROPS forms. Main thing we do is embolden the variable.") (if (NLISTP (CDR EXPR)) then (* ; "Degenerate (PUTPROPS) or (PUTPROPS . FOO)") (PRIN2 EXPR) else (PRIN1 (QUOTE %()) (PRIN2 (pop EXPR)) (* ; "Print the PUTPROPS") (SPACES 1) (LET ((TEM (DSPXPOSITION)) PROP) (MAYBE.PRETTYPRINT.BOLD (pop EXPR)) (* ; "Print the symbol") (if (OR (NLISTP EXPR) (NLISTP (CDR EXPR))) then (* ; "Some degenerate illegal form like (PUTPROPS var . foo)") (SPACES 1) (PRINTDEF EXPR T NIL T) elseif (CDDR EXPR) then (* ; "There are multiple prop value pairs") (while EXPR do (* ;; "EXPR looks like (PROP VALUE . tail)") (TERPRI) (* ; "Start next prop on new line") (DSPXPOSITION TEM) (if (OR (NLISTP EXPR) (NLISTP (CDR EXPR))) then (* ; "Some degenerate tail") (RETURN (PRINTDEF EXPR T NIL T))) (MAYBE.PRETTYPRINT.BOLD (SETQ PROP (pop EXPR))) (SPACES 1) (PRINTDEF (pop EXPR) T (MEMB PROP MACROPROPS) NIL FNSLST)) else (* ; "Normal type: (PUTPROPS var prop value)") (SPACES 1) (MAYBE.PRETTYPRINT.BOLD (SETQ PROP (pop EXPR))) (COND ((AND (LISTP (CAR EXPR)) (NOT (FITP EXPR T NIL NIL *STANDARD-OUTPUT*))) (* ; "The value is a list that doesn't fit well at this position, so put it on a new line.") (TERPRI) (DSPXPOSITION TEM)) (T (SPACES 1))) (PRINTDEF EXPR T (MEMB PROP MACROPROPS) T FNSLST)) (PRIN1 (QUOTE %))))) NIL)
)
(RPAQX.PRETTYPRINT
(LAMBDA (EXPR) (* ; "Edited 8-Apr-88 16:34 by bvm") (* ;; "does prettyprinting for RPAQxx forms and ADDTOVAR. Main thing we do is embolden the variable.") (if (NOT (LISTP (CDR EXPR))) then (* ; "Handle (RPAQ) and (RPAQ . FOO)") EXPR else (DESTRUCTURING-BIND (OP VAR . TAIL) EXPR (PRIN1 (QUOTE %()) (PRIN2 OP) (SPACES 1) (LET ((TEM (DSPXPOSITION))) (MAYBE.PRETTYPRINT.BOLD VAR) (* ; "Embolden the variable") (COND ((AND (LISTP (CAR TAIL)) (OR (> (COUNT TAIL) 30) (NOT (FITP TAIL T NIL NIL *STANDARD-OUTPUT*)))) (* ; "The value is a list that doesn't fit well at this position, so put it on a new line.") (TERPRI) (DSPXPOSITION TEM)) (T (SPACES 1))) (PRINTDEF TAIL T NIL T) (PRIN1 (QUOTE %))))) NIL))
)
(COURIERPROGRAM.PRETTYPRINT
(LAMBDA (EXPR) (* ; "Edited 13-Apr-88 10:55 by bvm") (if (NOT (LISTP (CDR (LISTP (CDR (LISTP (CDR EXPR))))))) then (* ; "Degenerate") EXPR else (LET* ((TAB1 (+ (DSPXPOSITION) (TIMES 4 SPACEWIDTH))) (TAB2 (+ TAB1 (TIMES 2 SPACEWIDTH)))) (PROGN (* ;; "Print %"(COURIERPROGRAM name (version)%"") (PRIN1 "(") (PRIN2 (pop EXPR)) (SPACES 1) (MAYBE.PRETTYPRINT.BOLD (pop EXPR)) (SPACES 1) (PRIN2 (pop EXPR))) (* ; "Version pair") (while (LISTP EXPR) do (PRINENDLINE TAB1) (MAYBE.PRETTYPRINT.BOLD (pop EXPR)) (* ; "Property name") (PRINENDLINE TAB2) (AND (LISTP EXPR) (PRINTDEF (pop EXPR) T))) (if EXPR then (* ; "degenerate tail?") (PRINTDEF EXPR T T T)) (PRIN1 ")") NIL)))
)
(MAYBE.PRETTYPRINT.BOLD
(LAMBDA (VAR) (* ; "Edited 28-Mar-88 11:59 by bvm") (* ;; "Print VAR, in makefile's bold font if enabled") (COND ((AND FONTCHANGEFLG PRETTYCOMFONT) (CHANGEFONT PRETTYCOMFONT) (PRIN2 VAR) (CHANGEFONT DEFAULTFONT)) (T (PRIN2 VAR))))
)
)
(ADDTOVAR PRETTYPRINTMACROS (RPAQ . RPAQX.PRETTYPRINT) (RPAQQ . RPAQX.PRETTYPRINT) (RPAQ? . RPAQX.PRETTYPRINT) (ADDTOVAR . RPAQX.PRETTYPRINT) (PUTPROPS . PUTPROPS.PRETTYPRINT) (COURIERPROGRAM . COURIERPROGRAM.PRETTYPRINT))
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(CL:PROCLAIM (QUOTE (CL:SPECIAL *PFI-PAGE-COUNT* *PFI-PAGE-PREFIX* *PFI-TITLE* *PFI-ITEM* *PFI-FNSLST* *PFI-INDEX-ALIST* *PFI-LOCATIONS* *PFI-FILEVARS* *PFI-FUNNY-CHARS* *PFI-PENDING-COMMENTS* *PFI-TWO-SIDED* *PFI-BITMAP-BASELINE* *OLD-INTERLISP-READ-ENVIRONMENT* *UPPER-CASE-FILE-NAMES* DEFAULTFONT BOLDFONT PRETTYCOMFONT LAMBDAFONT ITALICFONT FONTCHANGEFLG COMMENTFLG EMPRESS#SIDES PRETTYFLG)))
(DECLARE%: EVAL@COMPILE
(RECORD PFITYPE (NAME PATTERNS TESTFN AMBIGUOUS?))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \PFI.PROCESS.COMMANDS \PFI.PROCESSLOCK \PFI.PROCESS NOTLISTEDFILES MACROPROPS CLISPRECORDTYPES PROMPTWINDOW *PFI-DEFINER-PROPS* *COMMON-LISP-READ-ENVIRONMENT*)
)
)
(DECLARE%: EVAL@COMPILE DOCOPY
(CL:PROCLAIM (QUOTE (CL:SPECIAL *PFI-TYPES* *PFI-HANDLERS* *PFI-PREVIEWERS* *PFI-DONT-SPAWN* *PFI-PROPERTIES* *PFI-FILTERS* *PRINT-PRETTY-FROM-FILES* *PRINT-PRETTY-BITMAPS* *PFI-MAX-WASTED-LINES* *PFI-PRINTOPTIONS* *PFI-CHARACTER-TRANSLATIONS* *PFI-INDEX-ORDER*)))
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(OR (GETD (QUOTE CODEWRAPPER.PRETTYPRINT)) (FILESLOAD (SYSLOAD) DEFINERPRINT))
(* ; "Get prettyprinter fixes if running in old sysout")
(MOVD? (PROG ((SYMS (QUOTE ("OLDLISTFILES1" "LISTFILES1-ORIGINAL"))) S) (* ; "Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.") LP (COND ((AND (SETQ S (CL:FIND-SYMBOL (CAR SYMS))) (GETD S)) (RETURN (PROG1 S (COND ((SETQ S (CL:FIND-SYMBOL "MAYBE-PP-CODE-FILE")) (* ; "Also fix SEE") (MOVD (QUOTE PFI.MAYBE.SEE.PRETTY) S NIL T)))))) ((SETQ SYMS (CDR SYMS)) (GO LP)) (T (* ; "Neither one loaded, take original") (RETURN (QUOTE LISTFILES1))))) (QUOTE PFI.ORIGINAL.LISTFILES1) NIL T)
(MOVD (QUOTE PFI.NEW.LISTFILES1) (QUOTE LISTFILES1) NIL T)
(CHANGENAME (QUOTE SEE) (QUOTE COPYALLBYTES) (QUOTE PFI.MAYBE.SEE.PRETTY))
(CHANGENAME (QUOTE FB.FASTSEE.ONEFILE) (QUOTE PFCOPYBYTES) (QUOTE PFI.MAYBE.SEE.PRETTY))
(CHANGENAME (QUOTE PRINTFNDEF) (QUOTE PFCOPYBYTES) (QUOTE PFI.MAYBE.PP.DEFINITION))
(MOVD? (OR (DEFPRINT (QUOTE BITMAP) (QUOTE PFI.PRINT.BITMAP)) (QUOTE NILL)) (QUOTE NON.PFI.PRINT.BITMAP) NIL T)
)
(PUTPROPS PRETTYFILEINDEX COPYRIGHT ("Xerox Corporation" 1988))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (6466 8701 (PFI.NEW.LISTFILES1 6476 . 6970) (PFI.ENQUEUE 6972 . 7596) (\PFI.DO.HARDCOPY
7598 . 8184) (MAYBE.PRETTYFILEINDEX 8186 . 8699)) (8702 22679 (PRETTYFILEINDEX 8712 . 15869) (
PFI.MAKE.LPT.STREAM 15871 . 17260) (PFI.SETUP.TRANSLATIONS 17262 . 18776) (PFI.OUTCHARFN 18778 . 20752
) (PFI.COLLECT.DEFINERS 20754 . 21566) (PFI.AFTER.NEW.PAGE 21568 . 22677)) (22680 25536 (
PFI.PRINT.FILECREATED 22690 . 24422) (PFI.PRINT.TO.TAB 24424 . 24789) (PFI.PRINT.ENVIRONMENT 24791 .
25534)) (25537 32188 (PFI.PROCESS.FILE 25547 . 26777) (PFI.PASS.COMMENT 26779 . 27216) (
PFI.HANDLE.EXPR 27218 . 27885) (PFI.DEFAULT.HANDLER 27887 . 29940) (PFI.PRETTYPRINT 29942 . 30277) (
PFI.LINES.REMAINING 30279 . 30606) (PFI.MAYBE.NEW.PAGE 30608 . 31111) (PFI.ESTIMATE.SIZE 31113 . 31644
) (PFI.ESTIMATE.SIZE1 31646 . 32186)) (32225 41712 (PFI.HANDLE.RPAQQ 32235 . 33643) (
PFI.HANDLE.DECLARE 33645 . 34584) (PFI.HANDLE.EVAL-WHEN 34586 . 35069) (PFI.HANDLE.DEFDEFINER 35071 .
36361) (PFI.HANDLE.DEFINEQ 36363 . 36607) (PFI.PRINT.LAMBDA 36609 . 36947) (PFI.PRINT.LAMBDA.BODY
36949 . 37284) (PFI.HANDLE.PUTDEF 37286 . 37783) (PFI.HANDLE.PUTPROPS 37785 . 38400) (
PFI.HANDLE./DECLAREDATATYPE 38402 . 38949) (PFI.HANDLE.* 38951 . 40213) (PFI.PRINT.COMMENTS 40215 .
41115) (PFI.HANDLE.FILEMAP 41117 . 41405) (PFI.HANDLE.PACKAGE 41407 . 41710)) (41740 42732 (
PFI.PREVIEW.DECLARE 41750 . 42412) (PFI.PREVIEW.DEFINEQ 42414 . 42730)) (42768 53756 (PFI.PRINT.INDEX
42778 . 43629) (PFI.CONDENSE.INDEX 43631 . 45438) (PFI.SORT.INDICES 45440 . 46579) (
PFI.COMPUTE.INDEX.SHAPE 46581 . 48045) (PFI.PRINT.INDICES 48047 . 52589) (PFI.CENTER.PRINT 52591 .
53161) (PFI.INDEX.BREAK 53163 . 53621) (PFI.LOOKUP.NAME 53623 . 53754)) (53757 54988 (PFI.ADD.TO.INDEX
53767 . 54277) (PFI.VARNAME 54279 . 54689) (PFI.CONSTANTNAMES 54691 . 54986)) (55023 63336 (
MULTIFILEINDEX 55033 . 55829) (MULTIFILEINDEX1 55831 . 57287) (PFI.PRINT.MULTI.INDEX 57289 . 62392) (
PFI.CHOOSE.BEST 62394 . 62621) (PFI.MERGE.INDICES 62623 . 63334)) (63393 65011 (PFI.MAYBE.SEE.PRETTY
63403 . 64333) (PFI.MAYBE.PP.DEFINITION 64335 . 65009)) (65077 68912 (PFI.PRINT.BITMAP 65087 . 68910))
(70994 74108 (PUTPROPS.PRETTYPRINT 71004 . 72415) (RPAQX.PRETTYPRINT 72417 . 73142) (
COURIERPROGRAM.PRETTYPRINT 73144 . 73844) (MAYBE.PRETTYPRINT.BOLD 73846 . 74106)))))
STOP