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

(FILECREATED "31-Jul-87 18:21:27" {ERINYES}<LISPUSERS>LYRIC>SINGLEFILEINDEX.;4
 30550  

      changes to%:  (FNS SINGLEFILEINDEX2 SINGLEFILEINDEX1 \SFI.LISTINGHEADER PrintIndex \SFI.CENTERPRINT)

      previous date%: "23-Dec-86 19:20:26" {ERINYES}<LISPUSERS>LYRIC>SINGLEFILEINDEX.;1)


(* "
Copyright (c) 1984, 1985, 1986, 1987 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT SINGLEFILEINDEXCOMS)

(RPAQQ SINGLEFILEINDEXCOMS
 ((COMS (* ;;; "Created by Christopher Tong and JonL White, February 1984.  Heavily revised by Bill van Melle, March 1986.") (* ; "SINGLEFILEINDEX") (FNS SINGLEFILEINDEX \SFI.Q1UP \FILELISTING SINGLEFILEINDEX2 SINGLEFILEINDEX1 \SFI.AnalyzeLine \SFI.FLUSHFONTCHANGE PrintFnDef INDEXCOPYBYTES INDEXNEWLINE INDEXNEWPAGE \SFI.SORTINDEX UALPHORDERCAR \SFI.FILTER.INDEX) (FNS PrintFileTitle \SFI.PRINT.INDEX PrintIndex \SFI.PrintIndexFactors PrintRelativeFunctionIndex \SFI.CENTERPRINT PRINTDOTS \SFI.LISTINGHEADER \SFI.BreakLine)) (INITVARS (PRINTERDEVICEFILENAME (QUOTE {LPT})) (RELATIVEINDEXFLG) (SINGLEFILEINDEX.TWOSIDED) (SINGLEFILEINDEX.DONTSPAWN) (\SFI.PROCESS.COMMANDS) (\SFI.PROCESSLOCK (CREATE.MONITORLOCK "SINGLEFILEINDEX")) (\SFI.PROCESS) (ERRORMESSAGESTREAM T)) (ADDVARS (SINGLEFILEINDEX.TYPES (MACRO DEFMACRO) (OPTIMIZER DEFOPTIMIZER) (VAR (RPAQ RPAQ? RPAQQ ADDTOVAR) TestForVar T) (VAR READVARS TestForUglyVars) (BITMAP RPAQ TestForBitmap) (CONSTANTS CONSTANTS TestForConstants) (CONSTANTS CL:DEFCONSTANT) (RECORD (eval CLISPRECORDTYPES)) (STRUCTURES (CL:DEFSTRUCT) TestForDefstruct) (PROPERTY PUTPROPS TestForProp) (COURIERPROGRAM COURIERPROGRAM) (TEMPLATE SETTEMPLATE TestForQuotedType) (I.S.OPR I.S.OPR TestForQuotedType) (RESOURCES PUTDEF TestForResource) (ADVICE READVISE)) (SINGLEFILEINDEX.PROPERTIES (COPYRIGHT) (READVICE ADVICE)) (SINGLEFILEINDEX.FILTERS (VAR . CONSTANTS) (VAR . BITMAP))) (COMS (* ; "Functions that find types") (FNS TestForType TestForQuotedType TestForVar TestForBitmap TestForProp TestForResource TestForUglyVars TestForDefstruct TestForGenericDefinition TestForConstants SFI.WHOLE.EXPRESSION SFI.LOOKUP.NAME)) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS .ERRORSTREAM.) (RECORDS SFITYPE) (FILES (IMPORT) FILEIO) (GLOBALVARS DEFAULTFONT NOTLISTEDFILES) (GLOBALVARS FILERDTBL RELATIVEINDEXFLG) (GLOBALVARS SINGLEFILEINDEX.DONTSPAWN \SFI.PROCESS.COMMANDS \SFI.PROCESSLOCK \SFI.PROCESS SINGLEFILEINDEX.TWOSIDED SINGLEFILEINDEX.TYPES SINGLEFILEINDEX.PROPERTIES SINGLEFILEINDEX.FILTERS FILELINELENGTH MACROPROPS PRINTERDEVICEFILENAME) DONTEVAL@LOAD (SPECVARS . T)) (COMS (FNS SFI.LISTFILES1) (DECLARE%: DOCOPY DONTEVAL@LOAD (P (MOVD? (QUOTE LISTFILES1) (QUOTE OLDLISTFILES1)) (/MOVD (QUOTE SFI.LISTFILES1) (QUOTE LISTFILES1))) (INITVARS (LINESPERPAGE 65)))))
)



(* ;;; 
"Created by Christopher Tong and JonL White, February 1984.  Heavily revised by Bill van Melle, March 1986."
)





(* ; "SINGLEFILEINDEX")


(DEFINEQ

(SINGLEFILEINDEX

(LAMBDA (INF OUTF mergedIndexFlg PRINTOPTIONS) (* bvm%: "28-Mar-86 17:31") (LET ((FULL (FINDFILE INF T))) (COND ((NOT FULL) (* ; "When called by LISTFILES INF will already be a full file name") (printout (.ERRORSTREAM.) T INF " not found.")) (SINGLEFILEINDEX.DONTSPAWN (SINGLEFILEINDEX2 FULL OUTF mergedIndexFlg PRINTOPTIONS)) (T (\SFI.Q1UP (FUNCTION SINGLEFILEINDEX2) FULL OUTF mergedIndexFlg PRINTOPTIONS) (* ; "Used to return NIL so that LISTFILES won't try removing from NOTLISTEDFILES") FULL))))
)

(\SFI.Q1UP

(LAMBDA (FUN FULL OUTF mergedIndexFlg PRINTOPTIONS) (* bvm%: "15-Mar-86 17:11") (* ;;; "Add a command to list file FULL to OUTF applying FUN") (WITH.MONITOR \SFI.PROCESSLOCK (* ; "Lock protects \SFI.PROCESS.COMMANDS and \SFI.PROCESS") (COND ((AND \SFI.PROCESS (NOT (FIND.PROCESS \SFI.PROCESS))) (* ; "Process died, flush handle and any old listing requests") (SETQ \SFI.PROCESS (SETQ \SFI.PROCESS.COMMANDS NIL)))) (SETQ \SFI.PROCESS.COMMANDS (NCONC1 \SFI.PROCESS.COMMANDS (LIST FUN FULL OUTF mergedIndexFlg PRINTOPTIONS))) (COND ((NULL \SFI.PROCESS) (SETQ \SFI.PROCESS (ADD.PROCESS (LIST (FUNCTION \FILELISTING)) (QUOTE BEFOREEXIT) (QUOTE DON'T)))))))
)

(\FILELISTING

(LAMBDA NIL (* bvm%: "15-Mar-86 16:58") (* ;;; "Process that takes listing commands from \SFI.PROCESS.COMMANDS and performs them") (WITH.MONITOR \SFI.PROCESSLOCK (* ; "Lock protects \SFI.PROCESS.COMMANDS and \SFI.PROCESS") (while \SFI.PROCESS.COMMANDS bind FORM do (SETQ FORM (pop \SFI.PROCESS.COMMANDS)) (RELEASE.MONITORLOCK \SFI.PROCESSLOCK) (* ; "Release lock while listing so that others can add to my queue") (APPLY (CAR FORM) (CDR FORM)) (OBTAIN.MONITORLOCK \SFI.PROCESSLOCK) finally (* ; "Nothing left to do, so exit") (SETQ \SFI.PROCESS NIL))))
)

(SINGLEFILEINDEX2

(LAMBDA (FULL OUTF mergedIndexFlg PRINTOPTIONS) (* ; "Edited 31-Jul-87 18:19 by bvm:") (* ;;; "Process a single file FULL to OUTF with options.  SINGLEFILEINDEX should have already computed the fullname of the input file") (COND ((COND ((SINGLEFILEINDEX1 FULL OUTF mergedIndexFlg PRINTOPTIONS) (AND (NULL OUTF) (printout (.ERRORSTREAM.) T "indexed version of " (OR (LISTGET PRINTOPTIONS (QUOTE DOCUMENT.NAME)) FULL) " => " PRINTERDEVICEFILENAME)) T) (OUTF (printout (.ERRORSTREAM.) T FULL " is not LISPSOURCEFILEP -- COPYFILE being called")) (T (OLDLISTFILES1 FULL PRINTOPTIONS))) (* ;; "Do this here since there is little coordination between the various multiple processes which are listing files") (SETQ NOTLISTEDFILES (REMOVE (ROOTFILENAME FULL) NOTLISTEDFILES)) NIL)))
)

(SINGLEFILEINDEX1

(LAMBDA (FULL OUTF RETINDEXFLG PRINTOPTIONS) (* ; "Edited 31-Jul-87 18:20 by bvm:") (* ;; "Makes an indexed file (default is the line printer pseudo-file).  The index file will have a number of indices, one for each type in SINGLEFILEINDEX.TYPES.  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.") (* ;; "Note 1: The indices will be printed last.") (* ;; "Note 2: The index file is not 'loadable' into LISP.") (DECLARE (USEDFREE LINESPERPAGE)) (RESETLST (PROG ((LINESPERPAGE LINESPERPAGE) (typesLST (OR (NULL RELATIVEINDEXFLG) (EQ RELATIVEINDEXFLG (QUOTE BOTH)))) (FNUM 0) (SOURCESTREAM) (PAGECOUNT) (LINECOUNT 1) (ItemPages) (INDICES) (FILETITLE) lastPage MAP FULLEOLC COMS currentItem nextFnGroup nextFnStart FNSMAPSL TEM) (DECLARE (SPECVARS MAP LINECOUNT PAGECOUNT LINESPERPAGE SOURCESTREAM ItemPages typesLST FNUM currentItem linePos newPos INDICES FILETITLE)) (* ;; "Specials are as follows:") (* ;; "SOURCESTREAM -- stream on the input file being formatted") (* ;; "currentItem -- function, etc currently being printed") (* ;; "FNUM -- ordinal number of function currently being printed, when RELATIVEINDEXFLG") (* ;; "PAGECOUNT -- number of current page") (* ;; "LINECOUNT -- number of current line on page") (* ;; "ItemPages -- list of (name type page#) constituting the actual index") (RESETSAVE (SETQ SOURCESTREAM (OPENSTREAM FULL (QUOTE INPUT) (QUOTE OLD))) (QUOTE (PROGN (CLOSEF? OLDVALUE)))) (SETQ FULL (FULLNAME SOURCESTREAM)) (CL:MULTIPLE-VALUE-SETQ (ENV MAP) (GET-ENVIRONMENT-AND-FILEMAP SOURCESTREAM)) (COND ((OR (NULL MAP) (AND (NOT (RANDACCESSP SOURCESTREAM)) typesLST)) (* ;; "We just let the `old' listfiles do it when the file isn't RANDACCESSP or when it's probably some kind of binary file") (RETURN))) (OR OUTF (SETQ OUTF PRINTERDEVICEFILENAME)) (COND ((OPENP OUTF (QUOTE OUTPUT)) (RESETSAVE (OUTPUT (SETQ OUTF (GETSTREAM OUTF (QUOTE OUTPUT)))))) (T (RESETSAVE (OUTPUT (SETQ OUTF (OPENSTREAM OUTF (QUOTE OUTPUT) (QUOTE NEW)))) (QUOTE (PROGN (CLOSEF? (OUTPUT OLDVALUE))))))) (STREAMPROP OUTF (QUOTE PRINTOPTIONS) (APPEND PRINTOPTIONS (AND (NOT (SETQ FILETITLE (LISTGET PRINTOPTIONS (QUOTE DOCUMENT.NAME)))) (LIST (QUOTE DOCUMENT.NAME) (SETQ FILETITLE FULL))) (STREAMPROP OUTF (QUOTE PRINTOPTIONS)))) (* ; "Make sure printer knows original name of file") (SETQ LINESPERPAGE (OR (GETFILEINFO OUTF (QUOTE PAGEHEIGHT)) LINESPERPAGE)) (* ; "Determine printing parameters.") (RESETSAVE (LINELENGTH 1000 OUTF)) (WITH-READER-ENVIRONMENT ENV (COND (RELATIVEINDEXFLG (* ; "All index info up front, derived from file map, no absolute page numbers") (PrintFileTitle FILETITLE (GETFILEINFO SOURCESTREAM (QUOTE CREATIONDATE))) (PrintRelativeFunctionIndex MAP))) (COND (typesLST (SETQ typesLST (for ENTRY in SINGLEFILEINDEX.TYPES collect (COND ((EQ (CAR (LISTP (fetch (SFITYPE PATTERNS) of ENTRY))) (QUOTE eval)) (create SFITYPE PATTERNS ← (EVAL (CADR (fetch (SFITYPE PATTERNS) of ENTRY))) reusing ENTRY)) (T ENTRY)))) (* ;; "Now add definers to the list.") (SETQ typesLST (APPEND typesLST (for TYPE in FILEPKGTYPES bind HOW when (AND (LITATOM TYPE) (SETQ HOW (for DEFINER in (GET TYPE (QUOTE DEFINED-BY)) collect DEFINER when (SELECTQ (GET DEFINER (QUOTE DEFINITION-NAME)) ((CADR CL:SECOND) (* ; "for now, only know about definers named by their second elt.  Also ignore definers that are already in the list, since somebody may want to classify one differently, e.g. DEFMACRO as MACRO not FUNCTION.") (NOT (for ENTRY in typesLST thereis (EQMEMB DEFINER (fetch (SFITYPE PATTERNS) of ENTRY))))) NIL)))) collect (create SFITYPE NAME ← TYPE PATTERNS ← HOW)))))) (PROGN (SETQ FNSMAPSL (CDR MAP)) (SETQ FULLEOLC (fetch EOLCONVENTION of SOURCESTREAM)) (SETQ PAGECOUNT 1) (SETQ nextFnGroup (CDDR (CAR FNSMAPSL))) (SETQ nextFnStart (CADAR nextFnGroup))) (* ;; "Locate and print definitions for each item.") (bind linePos newPos (currentPos ← 0) (EOL ← (SELECTC FULLEOLC (CR.EOLC (CONCATCODES (CHARCODE (CR)))) (LF.EOLC (CONCATCODES (CHARCODE (LF)))) (CONCATCODES (CHARCODE (CR LF))))) while (SETQ newPos (FILEPOS EOL SOURCESTREAM currentPos)) do (* ; "currentPos = how far we have copied") (* ; "linePos = start of current line") (* ; "newPos = start of next line%"") (SETFILEPTR SOURCESTREAM (SETQ linePos currentPos)) (COND ((COND ((EQ (PEEKCCODE SOURCESTREAM) (CHARCODE ↑F)) (* ; "Line might start with a fontchange sequence") (\SFI.FLUSHFONTCHANGE SOURCESTREAM) (* ; "Advance linePos to after any font change chars") (AND nextFnStart (OR (IEQP linePos nextFnStart) (IEQP currentPos nextFnStart)))) (T (AND nextFnStart (IEQP linePos nextFnStart)))) (* ; "Index and print function group.") (for function in nextFnGroup do (SETQ newPos (PrintFnDef function OUTF))) (* ; "Should point us at the first of two closing parens") (pop FNSMAPSL) (SETQ nextFnGroup (CDDAR FNSMAPSL)) (SETQ nextFnStart (CADAR nextFnGroup))) (T (* ; "Print and index (when appropriate) next line.") (SELECTC FULLEOLC (CRLF.EOLC (READC SOURCESTREAM) (add newPos 1)) 0) (COND (typesLST (\SFI.AnalyzeLine SOURCESTREAM typesLST))) (INDEXCOPYBYTES SOURCESTREAM OUTF currentPos newPos) (* ; "Print the line.") (INDEXNEWLINE))) (SETQ currentPos (ADD1 newPos))) (SETQ lastPage PAGECOUNT) (* ;; "Print file index or indices.") (COND ((OR (NULL RELATIVEINDEXFLG) (EQ RELATIVEINDEXFLG (QUOTE BOTH))) (SETQ INDICES (\SFI.SORTINDEX ItemPages)) (LET ((VARS (ASSOC (QUOTE VAR) INDICES))) (* ; "Manually filter out the filecoms var") (RPLACD VARS (DREMOVE (ASSOC (FILECOMS FULL) (CDR VARS)) (CDR VARS)))) (\SFI.FILTER.INDEX INDICES) (LET ((FILETITLE NIL)) (DECLARE (SPECVARS FILETITLE)) (* ; "Leave off the heading on the first index page, since we're about to print the title centered.") (INDEXNEWPAGE T) (COND ((AND (EVENP PAGECOUNT) SINGLEFILEINDEX.TWOSIDED) (* ;; "Ensure that the index will not be on the back-side of a two-sided listing") (INDEXNEWPAGE T)))) (PrintFileTitle FILETITLE (GETFILEINFO SOURCESTREAM (QUOTE CREATIONDATE))) (\SFI.PRINT.INDEX INDICES)))) (RETURN (COND (RETINDEXFLG (CONS FULL INDICES)) (T FULL))))))
)

(\SFI.AnalyzeLine

(LAMBDA (SOURCESTREAM TYPETRIPLES FLG) (* bvm%: "30-Mar-86 15:07") (* ;;; "Retrieve line as string, beginning with first character that isn't a font change char,") (DECLARE (USEDFREE ItemPages)) (SELECTQ (GETSYNTAX (READCCODE SOURCESTREAM)) ((LEFTPAREN LEFTBRACKET) (* ;; "Note that if the first character on the line isn't a parens then this line can't be the start of anything interesting") (COND ((EQ (PEEKCCODE SOURCESTREAM) (CHARCODE ↑F)) (* ;; "It is possible to have a fontchange sequence just after the open parens, though most forms reserve the font change for the named object, coming up next") (\SFI.FLUSHFONTCHANGE SOURCESTREAM))) (LET ((FN (READ SOURCESTREAM)) HERE PAT MOVED? ITEMNAME) (SETQ HERE (GETFILEPTR SOURCESTREAM)) (for ENTRY in TYPETRIPLES when (COND ((EQ (SETQ PAT (fetch (SFITYPE PATTERNS) of ENTRY)) T) (* ; "Matches anything -- TESTFN must be doing all the work") T) ((LISTP PAT) (MEMB FN PAT)) (T (EQ FN PAT))) do (* ; "ENTRY thinks this line might be interesting") (COND (MOVED? (* ; "Previous test may have moved the file pointer, so bring it back") (SETFILEPTR SOURCESTREAM HERE) (SETQ MOVED? NIL))) (COND ((SETQ ITEMNAME (CAR (NLSETQ (APPLY* (OR (fetch (SFITYPE TESTFN) of ENTRY) (FUNCTION TestForType)) SOURCESTREAM FN ENTRY)))) (COND ((NLISTP ITEMNAME) (* ; "Single object to be indexed as the type in ENTRY") (push ItemPages (LIST (LET ((TYPE (fetch (SFITYPE NAME) of ENTRY))) (OR (CAR (LISTP TYPE)) TYPE)) ITEMNAME PAGECOUNT))) (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 ItemPages (LIST (CAR PAIR) NAME PAGECOUNT)))))) (COND ((NOT (fetch (SFITYPE AMBIGUOUS?) of ENTRY)) (RETURN))))) (SETQ MOVED? T)))) ((RIGHTPAREN RIGHTBRACKET) (* ; "Well, some lines will be the closing of a DEFINEQ or a DECLARE: or whatever") NIL) NIL))
)

(\SFI.FLUSHFONTCHANGE

(LAMBDA (STREAM) (* bvm%: "15-Mar-86 17:41") (while (EQ (PEEKCCODE STREAM) (CHARCODE ↑F)) do (READCCODE STREAM) (READCCODE STREAM) (add linePos 2)))
)

(PrintFnDef

(LAMBDA (FNDEF OUTSTREAM) (DECLARE (USEDFREE ItemPages FNUM SOURCESTREAM PAGECOUNT LINESPERPAGE LINECOUNT) (SPECVARS currentItem)) (* bvm%: "28-Mar-86 17:41") (* ;;; "Prints a FNDEF definition on the file OUTSTREAM --- FNDEF is map entry of form (name start . end)") (PROG ((END (CDDR FNDEF)) (currentItem (CAR FNDEF))) (add FNUM 1) (INDEXNEWLINE) (COND (RELATIVEINDEXFLG (printout NIL .SP (IDIFFERENCE FILELINELENGTH (IPLUS 2 (NCHARS FNUM))) .FONT BOLDFONT "[" FNUM "]" .FONT DEFAULTFONT .RESET))) (INDEXNEWLINE) (COND ((NOT (ILEQ (IPLUS LINECOUNT 3) LINESPERPAGE)) (INDEXNEWPAGE))) (push ItemPages (LIST (QUOTE FUNCTION) currentItem PAGECOUNT)) (* ; "Print out function.") (INDEXCOPYBYTES SOURCESTREAM OUTSTREAM (CADR FNDEF) END) (RETURN END)))
)

(INDEXCOPYBYTES

(LAMBDA (IN OUT START END) (DECLARE (USEDFREE LINECOUNT LINESPERPAGE)) (* bvm%: "15-Mar-86 17:50") (* ;; "This is similar to COPYBYTES except that, INDEXNEWLINE is called whenever an EOL is read, and IndexNewPage is called whenever a form feed is read") (SETFILEPTR IN START) (PROG ((INSTRM (GETSTREAM IN (QUOTE INPUT))) (OUTSTRM (GETSTREAM OUT (QUOTE OUTPUT))) EOLC NLFLG LOOKFORLF CH) (SETQ EOLC (fetch EOLCONVENTION of INSTRM)) (FRPTQ (IDIFFERENCE END START) (SELCHARQ (SETQ CH (BIN INSTRM)) (CR (SELECTC EOLC (CR.EOLC (SETQ LOOKFORLF NIL) (COND ((AND NLFLG (IGREATERP LINECOUNT (IDIFFERENCE LINESPERPAGE 5))) (* ; "double cr near end of page") (INDEXNEWPAGE) (SETQ NLFLG NIL)) (T (INDEXNEWLINE) (SETQ NLFLG T)))) (CRLF.EOLC (* ;; "Flag says that EOLC is CRLF and we are looking for next char to be LF.  Expanded out this way so that we can keep track of the character counts accurately") (SETQ LOOKFORLF T)) (PROGN (SETQ LOOKFORLF NIL) (\OUTCHAR OUTSTRM (CHARCODE CR))))) (LF (COND ((OR LOOKFORLF (EQ EOLC LF.EOLC)) (COND ((AND NLFLG (IGREATERP LINECOUNT (IDIFFERENCE LINESPERPAGE 5))) (* ; "double cr near end of page") (INDEXNEWPAGE) (SETQ NLFLG NIL)) (T (INDEXNEWLINE) (SETQ NLFLG T)))) (T (\OUTCHAR OUTSTRM (CHARCODE LF)) (* ;; "If LF comes thru, it is just a vertical tab.  Want to keep horizontal position the same, but update line-counts") (COND ((AND NLFLG (IGREATERP LINECOUNT (IDIFFERENCE LINESPERPAGE 5))) (* ; "double cr near end of page") (INDEXNEWPAGE) (SETQ NLFLG NIL)) (T (COND ((IGREATERP (add LINECOUNT 1) LINESPERPAGE) (INDEXNEWPAGE))) (SETQ NLFLG T))))) (SETQ LOOKFORLF NIL)) (FF (INDEXNEWPAGE) (SETQ NLFLG NIL) (SETQ LOOKFORLF NIL)) (PROGN (\BOUT OUTSTRM CH) (SETQ NLFLG NIL) (SETQ LOOKFORLF NIL))))) T)
)

(INDEXNEWLINE

(LAMBDA (DontPrintPageNbrFlg) (* JonL "13-Mar-84 22:04") (TERPRI) (COND ((IGREATERP (add LINECOUNT 1) LINESPERPAGE) (INDEXNEWPAGE DontPrintPageNbrFlg))))
)

(INDEXNEWPAGE

(LAMBDA (DontPrintPageNbrFlg) (* JonL "13-Mar-84 22:04") (PRIN3 (FCHARACTER (CHARCODE FF))) (POSITION NIL 0) (SETQ LINECOUNT 0) (COND (PAGECOUNT (add PAGECOUNT 1))) (\SFI.LISTINGHEADER DontPrintPageNbrFlg))
)

(\SFI.SORTINDEX

(LAMBDA (TRIPLES) (* bvm%: "29-Mar-86 17:26") (* ;;; "Sort 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), with each entry looking like (name . pagenumbers)") (LET ((TYPENAMES (CONS (QUOTE FUNCTION) (for X in SINGLEFILEINDEX.TYPES collect (CAR X)))) RESULT INDEX OLDNAME) (for TRIP in TRIPLES do (COND ((NULL (SETQ INDEX (ASSOC (CAR TRIP) RESULT))) (push RESULT (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))))) (for PAIR in RESULT do (SORT (CDR PAIR) (FUNCTION UALPHORDERCAR))) (SORT RESULT (FUNCTION (LAMBDA (X Y) (* ; "X is before Y if its car appears before Y's in TYPENAMES") (FMEMB (CAR Y) (CDR (FMEMB (CAR X) TYPENAMES))))))))
)

(UALPHORDERCAR

(LAMBDA (A B) (* JonL " 7-Mar-84 19:52") (* ;; "does case independent sort on the CAR of two elements.") (UALPHORDER (CAR A) (CAR B)))
)

(\SFI.FILTER.INDEX

(LAMBDA (INDICES) (* bvm%: "30-Mar-86 14:11") (* ;;; "Remove redundancies from the prepared INDICES") (DECLARE (SPECVARS INDICES)) (* ; "For SFI.LOOKUP.NAME") (for TYPEPAIR in INDICES bind FILTERS when (SETQ FILTERS (for FILTER in SINGLEFILEINDEX.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") (SFI.LOOKUP.NAME (CAR PAIR) F)) (T (APPLY* (CAR F) PAIR))))))))
)
)
(DEFINEQ

(PrintFileTitle

(LAMBDA (FILENAME DATE) (* bvm%: "15-Mar-86 17:17") (* ;;; "Print FILENAME title.  Should not be called unless FILENAME is essentially 'at the top of the page'") (\SFI.CENTERPRINT (CONCAT FILENAME "		" DATE) T) (\SFI.CENTERPRINT (CONCAT "-- Listed on " (DATE) " --")) (INDEXNEWLINE))
)

(\SFI.PRINT.INDEX

(LAMBDA (INDICES) (* bvm%: "30-Mar-86 15:52") (* ;;; "For each (type . entries) pair in INDICES print a pretty index for the items of the type") (for PAIR in INDICES when (CDR PAIR) do (PrintIndex (CDR PAIR) lastPage (CAR PAIR)) (INDEXNEWLINE T)) (\SFI.BreakLine))
)

(PrintIndex

(LAMBDA (INDEXPAIRS MAXINDEXNO TYPE) (* ; "Edited 31-Jul-87 17:49 by bvm:") (* ;;; "print index of items in IndexedList.") (DECLARE (USEDFREE LINESPERPAGE LINECOUNT)) (PROG ((INDEXNOWIDTH (COND ((< MAXINDEXNO 10) 1) ((< MAXINDEXNO 100) 2) (T (NCHARS MAXINDEXNO)))) NCOLUMNS NROWS WIDTH LEFT SPACING NROWSREMAINING LASTITEM) (DECLARE (SPECVARS NCOLUMNS LEFT WIDTH SPACING NROWS)) (SETQ WIDTH (+ (for PAIR in INDEXPAIRS bind largest (+ (NCHARS (CAR PAIR) T) (COND ((CDDR PAIR) (* ;; "When multiple page nos, must count the extra pages, plus an additional char each for the separating comma") (TIMES (LENGTH (CDDR PAIR)) (+ 1 INDEXNOWIDTH))) (T 0))) finally (RETURN $$EXTREME)) INDEXNOWIDTH 1)) (* ; "WIDTH is the widest any entry gets: name plus page numbers") (\SFI.PrintIndexFactors INDEXPAIRS) (* ; "Compute NCOLUMNS LEFT WIDTH SPACING NROWS") (SETQ NROWSREMAINING NROWS) (AND TYPE (\SFI.BreakLine)) (* ; "When TYPE is non-null, call is from PrintOneTypeIndex") (INDEXNEWLINE T) (COND (TYPE (COND ((AND (> (+ NROWS 3) (- LINESPERPAGE LINECOUNT)) (> LINECOUNT (LRSH LINESPERPAGE 1))) (* ;; "Don't start an indexing on the bottom half of a page which is going to cross a page boundary before the 'breaker'") (INDEXNEWPAGE T) (AND TYPE (\SFI.BreakLine)))) (\SFI.CENTERPRINT (CONCAT TYPE " INDEX") T T) (INDEXNEWLINE T))) (while INDEXPAIRS do (SETQ NROWS (IMIN NROWSREMAINING (- LINESPERPAGE LINECOUNT))) (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) (SETQ PAGENO (COND ((LISTP PAGENO) (* ; "More than one occurrence") (CONCATLIST (CDR (for P in PAGENO join (LIST "," P))))) (T (MKSTRING PAGENO)))) (printout NIL .FONT DEFAULTFONT |.P2| LABEL %,) (PRINTDOTS (- WIDTH (ADD1 (NCHARS LABEL T)) (NCHARS PAGENO))) (PRIN1 PAGENO) (COND ((NEQ COLUMN NCOLUMNS) (SPACES SPACING)))))) (add NEXTINDEX NROWS)) (INDEXNEWLINE T)) (COND ((SETQ INDEXPAIRS (CDR LASTITEM)) (INDEXNEWPAGE T) (SETQ NROWSREMAINING (ADD1 (IQUOTIENT (LENGTH INDEXPAIRS) NCOLUMNS))))))))
)

(\SFI.PrintIndexFactors

(LAMBDA (IndexedList) (* bvm%: "30-Mar-86 15:00") (DECLARE (USEDFREE NCOLUMNS LEFT WIDTH SPACING NROWS)) (LET ((LEN (LENGTH IndexedList))) (SETQ NCOLUMNS (IMAX 1 (IMIN LEN (IQUOTIENT FILELINELENGTH (IPLUS WIDTH 2))))) (* ; "Number of columns that fit if you allow 2 spaces between columns") (SETQ NROWS (IQUOTIENT (IPLUS LEN (SUB1 NCOLUMNS)) NCOLUMNS)) (SETQ NCOLUMNS (IQUOTIENT (IPLUS LEN (SUB1 NROWS)) NROWS)) (* ;; "This might reduce the number of columns if all the items, printed in NROWS rows, take fewer columns than originally allocated") (SETQ LEFT (IDIFFERENCE FILELINELENGTH (ITIMES (IPLUS WIDTH 2) NCOLUMNS))) (* ; "LEFT is number of spaces remaining after allocating the columns") (COND ((EQ NCOLUMNS 1) (* ; "Only one column, so either make it half the page width or the full width") (SETQ WIDTH (COND ((GREATERP WIDTH (IQUOTIENT FILELINELENGTH 2)) FILELINELENGTH) (T (IQUOTIENT FILELINELENGTH 2)))) (SETQ SPACING 0)) (T (SETQ WIDTH (IMIN (IPLUS WIDTH (IQUOTIENT LEFT 2)) (IDIFFERENCE (IQUOTIENT FILELINELENGTH NCOLUMNS) 2))) (* ; "Spaces LEFT gets divided between the dots an the between-column spaces.") (SETQ SPACING (COND ((EQ NCOLUMNS 1) 0) (T (IQUOTIENT (IDIFFERENCE FILELINELENGTH (ITIMES WIDTH NCOLUMNS)) (SUB1 NCOLUMNS)))))))))
)

(PrintRelativeFunctionIndex

(LAMBDA (MAP) (* bvm%: "31-Mar-86 15:59") (* ;;; "Create and print an index for the functions on the file.") (PROG ((MaxIndexNo 0) IndexedList currentItem) (SETQ IndexedList (for DFQ in MAP join (for function in (CDDR DFQ) collect (LIST (CAR function) (add MaxIndexNo 1))))) (* ; "Printout function index.") (COND ((NOT IndexedList) (INDEXNEWLINE T) (INDEXNEWLINE T) (printout NIL .FONT BOLDFONT "No Functions." .FONT DEFAULTFONT)) (T (PrintIndex (SORT IndexedList (FUNCTION UALPHORDERCAR)) MaxIndexNo))) (INDEXNEWPAGE T) (RETURN MAP)))
)

(\SFI.CENTERPRINT

(LAMBDA (STR BOLDFLG DontPrintPageNbrFlg) (* ; "Edited 31-Jul-87 17:59 by bvm:") (TAB (IQUOTIENT (- FILELINELENGTH (NCHARS STR)) 2)) (COND (BOLDFLG (printout NIL .FONT BOLDFONT STR .FONT DEFAULTFONT)) (T (printout NIL STR))) (INDEXNEWLINE DontPrintPageNbrFlg))
)

(PRINTDOTS

(LAMBDA (N FILE) (* bvm%: "15-Mar-86 16:28") (LET ((STRM (GETSTREAM FILE (QUOTE OUTPUT)))) (FRPTQ N (\OUTCHAR STRM (CHARCODE %.)))))
)

(\SFI.LISTINGHEADER

(LAMBDA (dontPrintPageNumberFlg) (* ; "Edited 31-Jul-87 18:10 by bvm:") (DECLARE (USEDFREE FILETITLE currentItem FNUM RELATIVEINDEXFLG)) (LET ((*PRINT-BASE* 10)) (COND (FILETITLE (PRIN1 FILETITLE))) (COND ((AND currentItem FNUM RELATIVEINDEXFLG) (printout NIL "  (" |.P2| currentItem "[" FNUM "] cont.)")) (currentItem (printout NIL "  (" |.P2| currentItem " cont.)"))) (TAB (- FILELINELENGTH 9) T) (COND ((AND PAGECOUNT (NOT dontPrintPageNumberFlg)) (printout NIL "Page " PAGECOUNT))) (INDEXNEWLINE) (INDEXNEWLINE)))
)

(\SFI.BreakLine

(LAMBDA NIL (* bvm%: "15-Mar-86 16:28") (INDEXNEWLINE T) (LET ((STRM (GETSTREAM NIL (QUOTE OUTPUT)))) (FRPTQ FILELINELENGTH (\OUTCHAR STRM (CHARCODE ~)))) (INDEXNEWLINE T))
)
)

(RPAQ? PRINTERDEVICEFILENAME
 (QUOTE {LPT}))

(RPAQ? RELATIVEINDEXFLG
 )

(RPAQ? SINGLEFILEINDEX.TWOSIDED
 )

(RPAQ? SINGLEFILEINDEX.DONTSPAWN
 )

(RPAQ? \SFI.PROCESS.COMMANDS
 )

(RPAQ? \SFI.PROCESSLOCK
 (CREATE.MONITORLOCK "SINGLEFILEINDEX"))

(RPAQ? \SFI.PROCESS
 )

(RPAQ? ERRORMESSAGESTREAM
 T)

(ADDTOVAR SINGLEFILEINDEX.TYPES
 (MACRO DEFMACRO) (OPTIMIZER DEFOPTIMIZER) (VAR (RPAQ RPAQ? RPAQQ ADDTOVAR) TestForVar T)
 (VAR READVARS TestForUglyVars) (BITMAP RPAQ TestForBitmap) (CONSTANTS CONSTANTS TestForConstants) (CONSTANTS CL:DEFCONSTANT)
 (RECORD (eval CLISPRECORDTYPES)) (STRUCTURES (CL:DEFSTRUCT) TestForDefstruct) (PROPERTY PUTPROPS TestForProp)
 (COURIERPROGRAM COURIERPROGRAM) (TEMPLATE SETTEMPLATE TestForQuotedType) (I.S.OPR I.S.OPR TestForQuotedType)
 (RESOURCES PUTDEF TestForResource) (ADVICE READVISE))

(ADDTOVAR SINGLEFILEINDEX.PROPERTIES
 (COPYRIGHT) (READVICE ADVICE))

(ADDTOVAR SINGLEFILEINDEX.FILTERS
 (VAR . CONSTANTS) (VAR . BITMAP))



(* ; "Functions that find types")


(DEFINEQ

(TestForType

(LAMBDA (STREAM FN TRIPLE) (* bvm%: "30-Mar-86 13:20") (* ;;; "Default testfn for types that are dumped in a form whose second element is the object's name") (LET ((NAME (READ STREAM))) (AND NAME (LITATOM NAME) NAME)))
)

(TestForQuotedType

(LAMBDA (STREAM FN TRIPLE) (* bvm%: "30-Mar-86 13:29") (* ;;; "Like TestForType, but tests for something where the second element of the form is the quoted name.") (LET ((NAME (READ STREAM))) (AND (EQ (CAR (LISTP NAME)) (QUOTE QUOTE)) (CADR NAME))))
)

(TestForVar

(LAMBDA (STREAM FN TRIPLE) (* bvm%: "29-Mar-86 17:02") (* ;;; "Called for expressions whose car is one of RPAQ, RPAQQ, RPAQ?, ADDTOVAR -- read the variable name following it.  Filters after the fact will remove duplications with other variable types") (LET (NAME) (COND ((AND (SETQ NAME (READ STREAM)) (LITATOM NAME) (NEQ NAME T) (NOT (FMEMB NAME (QUOTE (GLOBALVARS SPECVARS LOCALVARS NLAMA NLAML LAMA))))) (* ; "Ignore compiler-internal vars") NAME))))
)

(TestForBitmap

(LAMBDA (STREAM FN TRIPLE) (* bvm%: "28-Mar-86 17:06") (* ;;; "Called on (RPAQ --) in case the expression is (RPAQ var (READBITMAP))") (LET ((NAME (READ STREAM)) CHAR) (COND ((AND NAME (LITATOM NAME) (EQ (SETQ CHAR (SKIPSEPRCODES STREAM)) (CHARCODE "(")) (PROGN (READCCODE STREAM) (* ; "After the VARS name is the form (READBITMAP ...)") (EQ (RATOM STREAM) (QUOTE READBITMAP)))) NAME))))
)

(TestForProp

(LAMBDA (STREAM FN TRIPLE) (* bvm%: "31-Mar-86 12:13") (* ;;; "Called when given a PUTPROPS expression.  Determine what type it is by looking at the property name.  If no more specific type known, then index it as a PROPERTY") (LET ((NAME (READ STREAM)) (PROP (READ STREAM))) (* ; "See if PROP means something more specific than 'property'") (COND ((MEMB PROP MACROPROPS) (* ; "Do macros in line so that MACRONAMES can be dynamically changed.") (LIST (QUOTE MACRO) NAME)) (T (for PAIR in SINGLEFILEINDEX.PROPERTIES when (EQ (CAR PAIR) PROP) do (* ; "Index it under this other type") (RETURN (AND (CADR PAIR) (LIST (CADR PAIR) NAME))) finally (* ; "Nothing better, so index it as having a property") (RETURN NAME))))))
)

(TestForResource

(LAMBDA (STREAM FN TRIPLE) (* bvm%: "28-Mar-86 17:08") (TestForGenericDefinition STREAM FN (QUOTE ((RESOURCES GLOBALRESOURCES)))))
)

(TestForUglyVars

(LAMBDA (STREAM FN TRIPLE) (* bvm%: "30-Mar-86 15:42") (* ;;; "Uglyvars are dumped as (READVARS var1 var2 ...)") (CONS (QUOTE VAR) (CDR (SFI.WHOLE.EXPRESSION STREAM))))
)

(TestForDefstruct

(LAMBDA (STREAM FN TRIPLE) (* bvm%: " 9-Jun-86 14:09") (* ;;; "Called on (DEFSTRUCT --).  The structure name is either the second element, or the CAR of the second element") (LET (NAME) (COND ((EQ (SKIPSEPRCODES STREAM) (CHARCODE "(")) (* ; "Second element is a list, so skip paren") (READCCODE STREAM))) (COND ((AND (SETQ NAME (READ STREAM)) (LITATOM NAME)) NAME))))
)

(TestForGenericDefinition

(LAMBDA (STREAM FN TRIPLE) (* bvm%: "31-Mar-86 12:02") (* ;;; "Tests to see if expression is of the form (PUTDEF (QUOTE name) (QUOTE type) (QUOTE value)) where type is one specified in TRIPLE") (LET ((DESIREDTYPE (CAR TRIPLE)) NAME TYPE) (COND ((AND (PROGN (* ; "After the PUTDEF should find (QUOTE name)") (EQ (CAR (LISTP (SETQ NAME (READ STREAM)))) (QUOTE QUOTE))) (PROGN (* ; "then (QUOTE DESIREDTYPE)") (EQ (CAR (LISTP (SETQ TYPE (READ STREAM)))) (QUOTE QUOTE))) (OR (EQ (SETQ TYPE (CAR (LISTP (CDR TYPE)))) DESIREDTYPE) (AND (LISTP DESIREDTYPE) (MEMB TYPE DESIREDTYPE)))) (CADR NAME)))))
)

(TestForConstants

(LAMBDA (STREAM FN TRIPLE) (* bvm%: "30-Mar-86 14:17") (* ;;; "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 (SFI.WHOLE.EXPRESSION STREAM)) collect (COND ((LISTP X) (CAR X)) (T X)))))
)

(SFI.WHOLE.EXPRESSION

(LAMBDA (STREAM) (* bvm%: "30-Mar-86 13:34") (DECLARE (USEDFREE linePos)) (* ;;; "Called by testfns that want to see the whole expression") (SETFILEPTR STREAM linePos) (READ STREAM))
)

(SFI.LOOKUP.NAME

(LAMBDA (NAME TYPE) (* bvm%: "30-Mar-86 13:44") (ASSOC NAME (CDR (ASSOC TYPE INDICES)))))
)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 
(PUTPROPS .ERRORSTREAM. MACRO (NIL (SELECTQ ERRORMESSAGESTREAM (T PROMPTWINDOW) ERRORMESSAGESTREAM)))
)

(DECLARE%: EVAL@COMPILE

(RECORD SFITYPE
 (NAME PATTERNS TESTFN AMBIGUOUS?))
)

(FILESLOAD (IMPORT) FILEIO)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS DEFAULTFONT NOTLISTEDFILES)
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS FILERDTBL RELATIVEINDEXFLG)
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS SINGLEFILEINDEX.DONTSPAWN \SFI.PROCESS.COMMANDS \SFI.PROCESSLOCK \SFI.PROCESS SINGLEFILEINDEX.TWOSIDED SINGLEFILEINDEX.TYPES SINGLEFILEINDEX.PROPERTIES SINGLEFILEINDEX.FILTERS FILELINELENGTH MACROPROPS PRINTERDEVICEFILENAME)
)
DONTEVAL@LOAD 
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(SPECVARS . T)
)
)
(DEFINEQ

(SFI.LISTFILES1

(LAMBDA (FILE PRINTOPTIONS) (* rmk%: "26-Feb-85 10:36") (SINGLEFILEINDEX FILE NIL NIL PRINTOPTIONS)))
)
(DECLARE%: DOCOPY DONTEVAL@LOAD 
(MOVD? (QUOTE LISTFILES1) (QUOTE OLDLISTFILES1))
(/MOVD (QUOTE SFI.LISTFILES1) (QUOTE LISTFILES1))


(RPAQ? LINESPERPAGE
 65)
)
(PUTPROPS SINGLEFILEINDEX COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2972 18410 (SINGLEFILEINDEX 2982 . 3505) (\SFI.Q1UP 3507 . 4175) (\FILELISTING 4177 . 
4749) (SINGLEFILEINDEX2 4751 . 5548) (SINGLEFILEINDEX1 5550 . 11660) (\SFI.AnalyzeLine 11662 . 13586) 
(\SFI.FLUSHFONTCHANGE 13588 . 13764) (PrintFnDef 13766 . 14530) (INDEXCOPYBYTES 14532 . 16282) (
INDEXNEWLINE 16284 . 16457) (INDEXNEWPAGE 16459 . 16685) (\SFI.SORTINDEX 16687 . 17621) (UALPHORDERCAR
 17623 . 17778) (\SFI.FILTER.INDEX 17780 . 18408)) (18411 24169 (PrintFileTitle 18421 . 18726) (
\SFI.PRINT.INDEX 18728 . 19016) (PrintIndex 19018 . 21135) (\SFI.PrintIndexFactors 21137 . 22417) (
PrintRelativeFunctionIndex 22419 . 22989) (\SFI.CENTERPRINT 22991 . 23275) (PRINTDOTS 23277 . 23426) (
\SFI.LISTINGHEADER 23428 . 23971) (\SFI.BreakLine 23973 . 24167)) (25211 29371 (TestForType 25221 . 
25458) (TestForQuotedType 25460 . 25734) (TestForVar 25736 . 26207) (TestForBitmap 26209 . 26617) (
TestForProp 26619 . 27355) (TestForResource 27357 . 27510) (TestForUglyVars 27512 . 27703) (
TestForDefstruct 27705 . 28096) (TestForGenericDefinition 28098 . 28722) (TestForConstants 28724 . 
29045) (SFI.WHOLE.EXPRESSION 29047 . 29257) (SFI.LOOKUP.NAME 29259 . 29369)) (30151 30284 (
SFI.LISTFILES1 30161 . 30282)))))
STOP