(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)


(FILECREATED "10-May-2023 09:12:17" {DSK}<home>larry>il>medley>lispusers>PRETTYFILEINDEX.;12
 101009 

      :EDIT-BY "lmm"

      :CHANGES-TO (FNS PFI.PRINT.FILECREATED)

      :PREVIOUS-DATE " 3-Jul-2022 15:28:08" {DSK}<home>larry>il>medley>lispusers>PRETTYFILEINDEX.;11
)


(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* '(REGION (72 54 504 702]
               (*PFI-DONT-SPAWN*)
               (*PFI-MAX-WASTED-LINES* 12)
               [*PFI-CHARACTER-TRANSLATIONS* '((INTERPRESS (95 172)
                                                      (96 169 FAMILY CLASSIC)
                                                      (39 185 FAMILY CLASSIC]
               (*PFI-INDEX-ORDER* '(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 '("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 '(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 '(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 'CODEWRAPPER.PRETTYPRINT)
                      (FILESLOAD (SYSLOAD)
                             DEFINERPRINT))
                                                             (* ; 

                                                   "Get prettyprinter fixes if running in old sysout")

                  (MOVD? [PROG ((SYMS '("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 'PFI.MAYBE.SEE.PRETTY S NIL T))))]
                                     ((SETQ SYMS (CDR SYMS))
                                      (GO LP))
                                     (T                      (* ; "Neither one loaded, take original")

                                        (RETURN 'LISTFILES1]
                         'PFI.ORIGINAL.LISTFILES1 NIL T)
                  (MOVD 'PFI.NEW.LISTFILES1 'LISTFILES1 NIL T)
                  (CHANGENAME 'SEE 'COPYALLBYTES 'PFI.MAYBE.SEE.PRETTY)
                  (CHANGENAME 'FB.FASTSEE.ONEFILE 'PFCOPYBYTES 'PFI.MAYBE.SEE.PRETTY)
                  (CHANGENAME 'PRINTFNDEF 'PFCOPYBYTES 'PFI.MAYBE.PP.DEFINITION)
                  (MOVD? (OR (DEFPRINT 'BITMAP 'PFI.PRINT.BITMAP)
                             'NILL)
                         '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  5-May-2022 14:38 by rmk")


                                                            (* ; "Edited  9-Jul-2021 21:35 by rmk:")


                                                             (* ; "Edited 11-Apr-95 00:02 by rmk:")


                                                             (* ; "Edited 11-Jun-92 15:58 by cat")


    (* ;; "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* 'PRETTYFILEINDEX)
               (*PFI-PAGE-COUNT*)
               (*PFI-PAGE-PREFIX* "Page ")
               (*PFI-TWO-SIDED* (EQ (OR (LISTGET PRINTOPTIONS '%#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 'STREAM)
                  then
                                       (* ; "Already have input stream")

                       [SETQ *STANDARD-INPUT* (SETQ WASOPEN (GETSTREAM FILENAME 'INPUT]
                else
 (RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
                                          (SETQ *STANDARD-INPUT* (OPENSTREAM FILENAME 'INPUT
                                                                        'OLD
                                                                        '((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* 'RETURN T))
                     (if
 (NULL FILECREATED)
                         then
                                (* ; "Not a File Manager file")

                              (RETURN NIL)
                       elseif
 (NEQ (CAR (LISTP FILECREATED))
                                   '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]
              (CL:UNLESS DONTINDEX (CL:FORMAT PROMPTWINDOW "~%%Starting index of ~A." FILENAME))
              [if
 OUTSTREAM
                  then
 (SETQ *PFI-TITLE* FILENAME)
                       (SETQ *STANDARD-OUTPUT* (GETSTREAM OUTSTREAM 'OUTPUT))
                else
 (OR (SETQ *PFI-TITLE* (LISTGET PRINTOPTIONS 'DOCUMENT.NAME))
                         (push
 PRINTOPTIONS '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 (IMAGESTREAMP *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* 'AFTERNEWPAGEFN (FUNCTION PFI.AFTER.NEW.PAGE)) 
                                                             (* ; "Enable header printing")


                     (* ;; "RMK:  NOBIND here seems to be deliberate, it seems somehow to match the NOBIND that appears in PFI.HANDLE.RPAQQ.")


                     [SETQ *PFI-FILEVARS* `((,(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 `(RECORD ,CLISPRECORDTYPES)
                                                                 (PFI.COLLECT.DEFINERS
 *PFI-TYPES*] 
                                                             (* ; 

                                                   "Add known record types and definers to the list.")

                     (SETQ CRDATE (GETFILEINFO *STANDARD-INPUT* '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 '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 12-Nov-93 09:53 by rmk:")

                                                             (* ; "Edited 19-Aug-92 13:57 by jds")

    (LET* ((PRINTER (OR (LISTGET PRINTOPTIONS 'SERVER)
                        (LISTGET PRINTOPTIONS 'HOST)
                        (CAR (LISTP DEFAULTPRINTINGHOST))
                        DEFAULTPRINTINGHOST))
           [IMAGETYPE (COND
                         [(AND PRINTER (CADDR (LISTP PRINTER]
                         (T (CAR (MKLIST (PRINTERPROP (PRINTERTYPE PRINTER)
                                                'CANPRINT]
           (DEFAULTOPTIONS *PFI-PRINTOPTIONS*)
           REG S TEMPS SCALE DEFREGION)

          (* ;; "Get a dummy stream of the right image type, so we can get scaling right, etc.  The IMAGETYPE ... code is stolen from OPENIMAGESTREAM's decision for IMAGETYPE.")


          (SETQ TEMPS (OPENIMAGESTREAM "{NODIRCORE}" IMAGETYPE))
          (SETQ SCALE (DSPSCALE NIL TEMPS))
          (CLOSEF TEMPS)

          (* ;; "Scale the region from points to the stream's real units right up front.  Also, copy the options so can smash with LISTPUTs here and below.")


          (CL:WHEN (SETQ REG (LISTGET PRINTOPTIONS 'REGION))
              (LISTPUT (SETQ PRINTOPTIONS (APPEND PRINTOPTIONS))
                     'REGION
                     (SCALEREGION SCALE REG)))
          (CL:WHEN (SETQ REG (LISTGET DEFAULTOPTIONS 'REGION))
              (LISTPUT (SETQ DEFAULTOPTIONS (APPEND DEFAULTOPTIONS))
                     'REGION
                     (SCALEREGION SCALE REG)))

          (* ;; "Set up the margins (REGION) for the page correctly.")


          [COND
             ((AND (LISTGET PRINTOPTIONS 'LANDSCAPE)
                   (LISTGET DEFAULTOPTIONS 'REGION))         (* ; 

                               "Don't use default region when caller specified landscape (tee hee)")

              (LISTPUT DEFAULTOPTIONS 'REGION NIL))
             ([AND *PFI-TWO-SIDED* (SETQ REG (LISTGET DEFAULTOPTIONS 'REGION))
                   (NOT (LISTGET PRINTOPTIONS 'REGION]       (* ; "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 DEFAULTOPTIONS 'REGION (create
 REGION
                                                 using
 REG LEFT _ (- (fetch
 (REGION LEFT)
                                                                            of
 REG)
                                                                         (FIXR (FTIMES 18 SCALE]
          (SETQ PRINTOPTIONS (APPEND PRINTOPTIONS DEFAULTOPTIONS))
          (SETQ S (OPENIMAGESTREAM (CONCAT "{LPT}" (OR (CADR (LISTP PRINTER))
                                                       PRINTER ""))
                         IMAGETYPE PRINTOPTIONS))
          [STREAMPROP S 'PRINTOPTIONS (APPEND PRINTOPTIONS (STREAMPROP S '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 10-May-2023 08:43 by lmm")


                                                             (* ; "Edited  5-May-2022 21:53 by rmk")


                                                           (* ; "Edited 30-Nov-2021 22:08 by larry")


                                                           (* ; "Edited 30-Nov-2021 21:40 by larry")


                                                            (* ; "Edited  9-Jul-2021 07:59 by rmk:")


    (* ;; "Display the FILECREATED expression and environment prettily")


    (* ;; 

    "Form is (FILECREATED date filename filemaploc changes to: changes previous date: date filename)")


    (pop
 EXPR)
    (CHANGEFONT ITALICFONT)
    (PROG* [(STRINGS '("File created:  " "edit by: " "changes to:  " "previous date:  " 
                             "Read Table:  " "Package:  " "Base:  " "Format:  "))
            (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)
                   :EDIT-BY)
               THEN
 (PFI.PRINT.TO.TAB
 (POP
 STRINGS)
                           (POP
 STRWIDTHS)
                           TABSTOP)
                    (POP
 EXPR)
                    (PRIN1 (POP
 EXPR))
                    (TERPRI)
                    (TERPRI)
             ELSE
 (POP
 STRINGS)
                  (POP
 STRWIDTHS))
           (if
 (SELECTQ (CAR EXPR)
                   (changes (SETQ EXPR (CDR EXPR))
                            T)
                   (:CHANGES-TO T)
                   NIL)
               then
                                          (* ; "handle %"Changes to:%"")

                    (PFI.PRINT.TO.TAB
 (pop
 STRINGS)
                           (pop
 STRWIDTHS)
                           TABSTOP)
                    (SETQ EXPR (CDR EXPR))
                    (PRINTDEF (while
 (LISTP (CAR EXPR)) collect
 (pop
 EXPR))
                           T NIL T)
                    (TERPRI)
                    (TERPRI)
             else
 (pop
 STRINGS)
                  (pop
 STRWIDTHS))
           (if
 (SELECTQ (CAR EXPR)
                   (previous (SETQ EXPR (CDR EXPR))
                             T)
                   (:PREVIOUS-DATE 
                        T)
                   NIL)
               then
                                          (* ; "Handle %"Previous date:%"")

                    (PFI.PRINT.TO.TAB
 (pop
 STRINGS)
                           (pop
 STRWIDTHS)
                           TABSTOP)
                    (SETQ EXPR (CDR EXPR))
                    (PRINTOUT NIL (pop
 EXPR)
                           "  "
                           (pop
 EXPR)
                           T T)
             else
 (pop
 STRINGS)
                  (pop
 STRWIDTHS))

     (* ;; "Show environment")


           (PFI.PRINT.TO.TAB
 (pop
 STRINGS)
                  (pop
 STRWIDTHS)
                  TABSTOP)                                   (* ; "Read table")

           (PFI.PRINT.ENVIRONMENT
 ENV :READTABLE)
           (PFI.PRINT.TO.TAB
 (pop
 STRINGS)
                  (pop
 STRWIDTHS)
                  TABSTOP)                                   (* ; "Package")

           (PFI.PRINT.ENVIRONMENT
 ENV :PACKAGE)
           (if
 (NEQ *PRINT-BASE* 10)
               then
 (PFI.PRINT.TO.TAB
 (pop
 STRINGS)
                           (pop
 STRWIDTHS)
                           TABSTOP)
                    (PFI.PRINT.ENVIRONMENT
 ENV :BASE)
             else
 (pop
 STRINGS))
           (PFI.PRINT.TO.TAB
 (pop
 STRINGS)
                  (pop
 STRWIDTHS)
                  TABSTOP)                                   (* ; "Format")

           (PFI.PRINT.ENVIRONMENT
 ENV :FORMAT])

(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 (ENV KEYWORD)
                                 (* ; "Edited  9-Jul-2021 08:03 by rmk:")


    (* ;; "Display the KEYWORD component of a reader environment spec")


    (LET [(VALUE (SELECTQ KEYWORD
                     (:READTABLE (READTABLEPROP (FETCH
 (READER-ENVIRONMENT REREADTABLE)
                                                   OF
 ENV)
                                        'NAME))
                     (:PACKAGE (CL:PACKAGE-NAME (FETCH
 (READER-ENVIRONMENT REPACKAGE)
                                                   OF
 ENV)))
                     (:BASE (FETCH
 (READER-ENVIRONMENT REBASE) OF
 ENV))
                     (:FORMAT (FETCH
 (READER-ENVIRONMENT REFORMAT) OF
 ENV))
                     (SHOULDNT]
         (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.  ")

                 (PRIN3 VALUE))
         (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 12-Mar-93 11:09 by rmk:")

                                                             (* ; "Edited 15-Apr-88 18:16 by bvm")


    (* ;; "Copy a semi-colon comment to the output stream")


    (TERPRI)
    (CHANGEFONT COMMENTFONT)
    [BIND
 CH DO
 (SETQ CH (READCCODE *STANDARD-INPUT*))
                       (IF
 [NOT (MEMB CH (CHARCODE (EOL LINEFEED]
                           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  5-May-2022 23:31 by rmk")


                                                             (* ; "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 (IMAGESTREAMP *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  5-May-2022 23:27 by rmk")


                                                             (* ; "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 (IMAGESTREAMP *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  5-May-2022 14:29 by rmk")


                                                             (* ; "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 (IMAGESTREAMP 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 'CLOSEF (SETQ INSTREAM (OPENSTREAM
                                                                          FROMFILE
                                                                          'INPUT NIL
                                                                          '((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  5-May-2022 23:14 by rmk")


                                                             (* ; "Edited  1-Apr-88 11:22 by bvm")

    (LET (ENV)
         (if
 [OR (NULL *PRINT-PRETTY-FROM-FILES*)
                 (NOT (IMAGESTREAMP 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 '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  3-Jul-2022 15:28 by rmk: Use vertical size in RATIO only if bottom and top margins exists")


    (* ;; "Edited  3-Jul-2022 15:24 by rmk")


    (* ;; "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))
                                                (CL:IF (AND BMARG (DSPTOPMARGIN NIL STREAM))
                                                    (FQUOTIENT (- (DSPTOPMARGIN NIL STREAM)
                                                                  BMARG)
                                                           (TIMES HEIGHT 1.5))
                                                    MAX.SMALLP)))
                               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 '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 'INPUT 'REPLACE NIL NIL SCALE
                          )
                   (MOVETO (+ CURX WIDTH)
                          (if
 (AND (< BOTTOM CURY)
                                   (EQ *PRINT-PRETTY-BITMAPS* '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* 'PRETTYFILEINDEX)
                           (PNAMESTREAMP STREAM)
                           (STKPOS 'STRINGWIDTH]
                 IMSTREAM)
                (if
 [AND POS (IMAGESTREAMP (SETQ IMSTREAM (STKEVAL POS '*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*
 '(REGION (72 54 504 702)))

(RPAQ? *PFI-DONT-SPAWN*
 )

(RPAQ? *PFI-MAX-WASTED-LINES*
 12)

(RPAQ? *PFI-CHARACTER-TRANSLATIONS*
 '((INTERPRESS (95 172)
                                             (96 169 FAMILY CLASSIC)
                                             (39 185 FAMILY CLASSIC))))

(RPAQ? *PFI-INDEX-ORDER*
 '(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 '("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 '(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 '(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 'CODEWRAPPER.PRETTYPRINT)
    (FILESLOAD (SYSLOAD)
           DEFINERPRINT))

                                                             (* ; 

                                                   "Get prettyprinter fixes if running in old sysout")


(MOVD? [PROG ((SYMS '("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 'PFI.MAYBE.SEE.PRETTY S NIL T))))]
                ((SETQ SYMS (CDR SYMS))
                 (GO LP))
                (T                                           (* ; "Neither one loaded, take original")

                   (RETURN 'LISTFILES1]
       'PFI.ORIGINAL.LISTFILES1 NIL T)

(MOVD 'PFI.NEW.LISTFILES1 'LISTFILES1 NIL T)

(CHANGENAME 'SEE 'COPYALLBYTES 'PFI.MAYBE.SEE.PRETTY)

(CHANGENAME 'FB.FASTSEE.ONEFILE 'PFCOPYBYTES 'PFI.MAYBE.SEE.PRETTY)

(CHANGENAME 'PRINTFNDEF 'PFCOPYBYTES 'PFI.MAYBE.PP.DEFINITION)

(MOVD? (OR (DEFPRINT 'BITMAP 'PFI.PRINT.BITMAP)
           'NILL)
       'NON.PFI.PRINT.BITMAP NIL T)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (9974 12209 (PFI.NEW.LISTFILES1 9984 . 10478) (PFI.ENQUEUE 10480 . 11104) (
\PFI.DO.HARDCOPY 11106 . 11692) (MAYBE.PRETTYFILEINDEX 11694 . 12207)) (12210 34725 (PRETTYFILEINDEX 
12220 . 26253) (PFI.MAKE.LPT.STREAM 26255 . 29306) (PFI.SETUP.TRANSLATIONS 29308 . 30822) (
PFI.OUTCHARFN 30824 . 32798) (PFI.COLLECT.DEFINERS 32800 . 33612) (PFI.AFTER.NEW.PAGE 33614 . 34723)) 
(34726 41240 (PFI.PRINT.FILECREATED 34736 . 39427) (PFI.PRINT.TO.TAB 39429 . 39874) (
PFI.PRINT.ENVIRONMENT 39876 . 41238)) (41241 48756 (PFI.PROCESS.FILE 41251 . 42481) (PFI.PASS.COMMENT 
42483 . 43453) (PFI.HANDLE.EXPR 43455 . 44122) (PFI.DEFAULT.HANDLER 44124 . 46177) (PFI.PRETTYPRINT 
46179 . 46514) (PFI.LINES.REMAINING 46516 . 46843) (PFI.MAYBE.NEW.PAGE 46845 . 47679) (
PFI.ESTIMATE.SIZE 47681 . 48212) (PFI.ESTIMATE.SIZE1 48214 . 48754)) (48793 59002 (PFI.HANDLE.RPAQQ 
48803 . 50211) (PFI.HANDLE.DECLARE 50213 . 51152) (PFI.HANDLE.EVAL-WHEN 51154 . 51637) (
PFI.HANDLE.DEFDEFINER 51639 . 52929) (PFI.HANDLE.DEFINEQ 52931 . 53175) (PFI.PRINT.LAMBDA 53177 . 
53515) (PFI.PRINT.LAMBDA.BODY 53517 . 53852) (PFI.HANDLE.PUTDEF 53854 . 54351) (PFI.HANDLE.PUTPROPS 
54353 . 54968) (PFI.HANDLE./DECLAREDATATYPE 54970 . 55517) (PFI.HANDLE.* 55519 . 56781) (
PFI.PRINT.COMMENTS 56783 . 58405) (PFI.HANDLE.FILEMAP 58407 . 58695) (PFI.HANDLE.PACKAGE 58697 . 59000
)) (59030 60022 (PFI.PREVIEW.DECLARE 59040 . 59702) (PFI.PREVIEW.DEFINEQ 59704 . 60020)) (60058 71046 
(PFI.PRINT.INDEX 60068 . 60919) (PFI.CONDENSE.INDEX 60921 . 62728) (PFI.SORT.INDICES 62730 . 63869) (
PFI.COMPUTE.INDEX.SHAPE 63871 . 65335) (PFI.PRINT.INDICES 65337 . 69879) (PFI.CENTER.PRINT 69881 . 
70451) (PFI.INDEX.BREAK 70453 . 70911) (PFI.LOOKUP.NAME 70913 . 71044)) (71047 72278 (PFI.ADD.TO.INDEX
 71057 . 71567) (PFI.VARNAME 71569 . 71979) (PFI.CONSTANTNAMES 71981 . 72276)) (72313 80626 (
MULTIFILEINDEX 72323 . 73119) (MULTIFILEINDEX1 73121 . 74577) (PFI.PRINT.MULTI.INDEX 74579 . 79682) (
PFI.CHOOSE.BEST 79684 . 79911) (PFI.MERGE.INDICES 79913 . 80624)) (80683 83752 (PFI.MAYBE.SEE.PRETTY 
80693 . 82476) (PFI.MAYBE.PP.DEFINITION 82478 . 83750)) (83822 91932 (PFI.PRINT.BITMAP 83832 . 91930))
 (94701 97815 (PUTPROPS.PRETTYPRINT 94711 . 96122) (RPAQX.PRETTYPRINT 96124 . 96849) (
COURIERPROGRAM.PRETTYPRINT 96851 . 97551) (MAYBE.PRETTYPRINT.BOLD 97553 . 97813)))))
STOP