(FILECREATED "30-Mar-86 15:58:57" {ERIS}<LISPCORE>BVM>SINGLEFILEINDEX.;9 54514
changes to: (FNS TestForProp TestForUglyVars SINGLEFILEINDEX1 \SFI.PRINT.INDEX
\SFI.AnalyzeLine PrintIndex \SFI.PrintIndexFactors TestForType
TestForQuotedType TestForConstants SFI.WHOLE.EXPRESSION SFI.ADD.TO.INDEX
SFI.LOOKUP.NAME \SFI.FILTER.INDEX \SFI.SORTINDEX TestForVar TestForMacro
TestForBitmap TestForResource TestForGenericDefinition SINGLEFILEINDEX
MERGEDFILEINDEX PrintFnDef MERGEDFILEINDEX1 SINGLEFILEINDEX2 MERGEDFILEINDEX2
)
(VARS SINGLEFILEINDEXCOMS)
(RECORDS SFITYPE)
previous date: "28-Mar-86 17:44:49" {ERIS}<LISPCORE>BVM>SINGLEFILEINDEX.;3)
(* Copyright (c) 1984, 1985, 1986 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 PUTPROPS TestForMacro)
(MACRO DEFMACRO)
(VAR (RPAQ RPAQ? RPAQQ ADDTOVAR)
TestForVar T)
(VAR READVARS TestForUglyVars)
(BITMAP RPAQ TestForBitmap)
(CONSTANTS CONSTANTS TestForConstants)
(RECORD (eval CLISPRECORDTYPES))
(PROPERTY PUTPROPS TestForProp)
(COURIERPROGRAM COURIERPROGRAM)
(TEMPLATE SETTEMPLATE TestForQuotedType)
(I.S.OPR I.S.OPR TestForQuotedType)
(RESOURCES PUTDEF TestForResource)
(ADVICE READVISE))
(SINGLEFILEINDEX.PROPERTIES (READVICE ADVICE))
(SINGLEFILEINDEX.FILTERS (VAR . CONSTANTS)
(VAR . BITMAP)))
(COMS (* "Functions that find types")
(FNS TestForType TestForQuotedType TestForVar TestForMacro TestForBitmap TestForProp
TestForResource TestForUglyVars 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) (* bvm: "28-Mar-86 17:44")
(* * 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 " 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) (* bvm: "30-Mar-86 15:53")
(* Makes an indexed file (default is the line printer)%.
The index file will have a number of indices, one for each type in
INDEXEDTYPESLIST. Each type index will list all the items of that type NIL in
alphabetical order and the page number of where that item's definition is in
the file. -
NOTE1: The indices will be printed last.
-
NOTE2: The index file is not "loadable" into LISP.)
(DECLARE (SPECVARS FULL)
(USEDFREE LINESPERPAGE))
(RESETLST (PROG ((LINESPERPAGE LINESPERPAGE)
(typesLST)
(FNUM 0)
(SOURCESTREAM)
(PAGECOUNT)
(LINECOUNT 1)
(ItemPages)
(INDICES)
lastPage MAP FULLEOLC COMS currentItem nextFnGroup nextFnStart FNSMAPSL TEM)
(DECLARE (SPECVARS MAP LINECOUNT PAGECOUNT LINESPERPAGE SOURCESTREAM ItemPages
typesLST FNUM currentItem linePos newPos INDICES))
(* * 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))
(COND
([EQ FULL (CAR (SETQ TEM (LISTP (GETP (ROOTFILENAME FULL)
(QUOTE FILEMAP]
(* It appears as though the file has
already been loaded in some way so
that the MAP is already loaded)
(SETQ MAP (CADR TEM)))
((NULL USEMAPFLG)
(RESETSAVE NIL (QUOTE (SETQ USEMAPFLG)))
(* Really should bind USEMAPFLG to T
but this works if the system still
thinks it's a globalvar)
(SETQ USEMAPFLG T)))
(COND
([OR (AND (NOT (RANDACCESSP SOURCESTREAM))
(OR typesLST (NULL MAP)))
(AND (NULL MAP)
(NULL (SETQ MAP (GETFILEMAP FULL)))
(NOT (LISPSOURCEFILEP FULL] (* 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 (LIST (QUOTE DOCUMENT.NAME)
FULL)
(STREAMPROP OUTF (QUOTE PRINTOPTIONS]
(* Make sure printer knows original
name of file)
(RESETSAVE (RADIX 10))
(SETQ LINESPERPAGE (OR (GETFILEINFO OUTF (QUOTE PAGEHEIGHT))
LINESPERPAGE)) (* Determine printing parameters.)
(RESETSAVE (LINELENGTH 1000 OUTF))
(COND
(RELATIVEINDEXFLG (* All index info up front, derived
from file map, no absolute page
numbers)
(PrintFileTitle FULL (GETFILEINFO SOURCESTREAM (QUOTE CREATIONDATE)))
(PrintRelativeFunctionIndex MAP)))
[COND
((OR (NULL RELATIVEINDEXFLG)
(EQ RELATIVEINDEXFLG (QUOTE BOTH)))
(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]
(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)
(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 FULL (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)
FILERDTBL)
((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 FILERDTBL))
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) (* bvm: "30-Mar-86 15:34")
(* * print index of items in IndexedList.)
(DECLARE (USEDFREE LINESPERPAGE LINECOUNT))
(PROG ([INDEXNOWIDTH (COND
((ILESSP MaxIndexNo 10)
1)
((ILESSP MaxIndexNo 100)
2)
(T (NCHARS MaxIndexNo]
NCOLUMNS NROWS WIDTH LEFT SPACING NROWSREMAINING LastItem)
(DECLARE (SPECVARS NCOLUMNS LEFT WIDTH SPACING NROWS))
(SETQ WIDTH (IPLUS (for PAIR in INDEXPAIRS bind
largest (PLUS (NCHARS (CAR PAIR))
(COND
((CDDR PAIR)(* When multiple page nos, must count
the extra pages, plus an additional
char each for the separating comma)
(ITIMES (LENGTH (CDDR PAIR))
(IPLUS 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 (IGREATERP (IPLUS NROWS 3)
(IDIFFERENCE LINESPERPAGE LINECOUNT))
(IGREATERP 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 (IDIFFERENCE 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))
(LET*((ITEM (CAR LastItem))
(LABEL (CAR ITEM))
(PAGENO (CDR ITEM)))
[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 LABEL ,)
(PRINTDOTS (IDIFFERENCE (IDIFFERENCE WIDTH (ADD1 (NCHARS LABEL)))
(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: "15-Mar-86 17:50")
(* * 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 (CONS (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 IndexedList MaxIndexNo)))
(INDEXNEWPAGE T)
(RETURN MAP])
(\SFI.CENTERPRINT
[LAMBDA (STR BOLDFLG DontPrintPageNbrFlg) (* JonL "13-Mar-84 22:07")
(TAB (LRSH (IDIFFERENCE FILELINELENGTH (NCHARS STR))
1))
(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) (* cht: " 5-JAN-84 15:15")
(COND
(FULL (PRIN1 FULL)))
(COND
((AND currentItem FNUM RELATIVEINDEXFLG)
(printout NIL " (" .P2 currentItem "[" FNUM "] cont.)"))
(currentItem (printout NIL " (" .P2 currentItem " cont.)")))
(TAB (IDIFFERENCE FILELINELENGTH 9)
T)
(COND
((AND PAGECOUNT (NOT dontPrintPageNumberFlg))
(PRIN1 "Page ")
(PRINTNUM (QUOTE (FIX 4))
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 PUTPROPS TestForMacro)
(MACRO DEFMACRO)
(VAR (RPAQ RPAQ? RPAQQ ADDTOVAR)
TestForVar T)
(VAR READVARS TestForUglyVars)
(BITMAP RPAQ TestForBitmap)
(CONSTANTS CONSTANTS TestForConstants)
(RECORD (eval CLISPRECORDTYPES))
(PROPERTY PUTPROPS TestForProp)
(COURIERPROGRAM COURIERPROGRAM)
(TEMPLATE SETTEMPLATE TestForQuotedType)
(I.S.OPR I.S.OPR TestForQuotedType)
(RESOURCES PUTDEF TestForResource)
(ADVICE READVISE))
(ADDTOVAR SINGLEFILEINDEX.PROPERTIES (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 FILERDTBL)))
(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 FILERDTBL)))
(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 FILERDTBL))
(LITATOM NAME)
(NEQ NAME T)
(NOT (FMEMB NAME (QUOTE (GLOBALVARS SPECVARS LOCALVARS NLAMA NLAML LAMA]
(* Ignore compiler-internal vars)
NAME])
(TestForMacro
[LAMBDA (STREAM FN TRIPLE) (* bvm: "28-Mar-86 17:01")
(* * called on (PUTPROPS name prop &) to test case where a macro is being
defined, i.e., prop is in MACROPROPS)
(LET ((MACRONAME (READ STREAM FILERDTBL))
(PROP (READ STREAM FILERDTBL)))
(AND (FMEMB PROP MACROPROPS)
MACRONAME])
(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 FILERDTBL))
CHAR)
(COND
([AND NAME (LITATOM NAME)
(EQ (SETQ CHAR (SKIPSEPRCODES STREAM FILERDTBL))
(CHARCODE "("))
(PROGN (READCCODE STREAM) (* After the VARS name is the form
(READBITMAP ...))
(EQ (RATOM STREAM FILERDTBL)
(QUOTE READBITMAP]
NAME])
(TestForProp
[LAMBDA (STREAM FN TRIPLE) (* bvm: "30-Mar-86 15:44")
(* * Called when given a PUTPROPS expression.
We assume TestForMacro has already filtered out the macros)
(LET ((NAME (READ STREAM FILERDTBL))
(PROP (READ STREAM FILERDTBL))) (* See if PROP means something more
specific than "property")
(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])
(TestForGenericDefinition
[LAMBDA (STREAM FN TRIPLE) (* bvm: "28-Mar-86 17:12")
(* * 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 FILERDTBL]
(QUOTE QUOTE)))
(PROGN (* then (QUOTE DESIREDTYPE))
(EQ [CAR (LISTP (SETQ TYPE (READ SOURCESTREAM FILERDTBL]
(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 FILERDTBL])
(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))
(DECLARE: DONTCOPY
(FILEMAP (NIL (4446 34962 (SINGLEFILEINDEX 4456 . 5358) (\SFI.Q1UP 5360 . 6604) (\FILELISTING 6606 .
7814) (SINGLEFILEINDEX2 7816 . 9001) (SINGLEFILEINDEX1 9003 . 20543) (\SFI.AnalyzeLine 20545 . 25333)
(\SFI.FLUSHFONTCHANGE 25335 . 25656) (PrintFnDef 25658 . 26783) (INDEXCOPYBYTES 26785 . 30522) (
INDEXNEWLINE 30524 . 30778) (INDEXNEWPAGE 30780 . 31078) (\SFI.SORTINDEX 31080 . 33036) (UALPHORDERCAR
33038 . 33386) (\SFI.FILTER.INDEX 33388 . 34960)) (34963 45376 (PrintFileTitle 34973 . 35420) (
\SFI.PRINT.INDEX 35422 . 35977) (PrintIndex 35979 . 40492) (\SFI.PrintIndexFactors 40494 . 42990) (
PrintRelativeFunctionIndex 42992 . 43945) (\SFI.CENTERPRINT 43947 . 44294) (PRINTDOTS 44296 . 44501) (
\SFI.LISTINGHEADER 44503 . 45101) (\SFI.BreakLine 45103 . 45374)) (46788 53222 (TestForType 46798 .
47147) (TestForQuotedType 47149 . 47552) (TestForVar 47554 . 48271) (TestForMacro 48273 . 48691) (
TestForBitmap 48693 . 49443) (TestForProp 49445 . 50523) (TestForResource 50525 . 50722) (
TestForUglyVars 50724 . 50992) (TestForGenericDefinition 50994 . 52123) (TestForConstants 52125 .
52750) (SFI.WHOLE.EXPRESSION 52752 . 53059) (SFI.LOOKUP.NAME 53061 . 53220)) (54061 54241 (
SFI.LISTFILES1 54071 . 54239)))))
STOP