(FILECREATED "29-Dec-84 10:41:40" {ERIS}<LISPCORE>LIBRARY>SINGLEFILEINDEX.;25 64664
changes to: (FNS \SFI.AnalyzeLine SINGLEFILEINDEX1 SINGLEFILEINDEX SINGLEFILEINDEX2)
(VARS SINGLEFILEINDEXCOMS)
previous date: "19-Dec-84 05:00:03" {ERIS}<LISPCORE>LIBRARY>SINGLEFILEINDEX.;19)
(* Copyright (c) 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT SINGLEFILEINDEXCOMS)
(RPAQQ SINGLEFILEINDEXCOMS ((* * "Created by Christopher Tong and JonL White, February 1984.")
(COMS (* "Temporary kludge patch")
(P (AND (BOUNDP (QUOTE INDEXEDTYPESLST))
(NULL INDEXEDTYPESLST)
(SETQ INDEXEDTYPESLST (QUOTE NOBIND)))))
(INITVARS (PRINTER (SELECTQ (SYSTEMTYPE)
(D (QUOTE {LPT}))
(QUOTE LPT:)))
(RELATIVEINDEXFLG)
(\SFI.INDIRECTION "Indirection Marker")
(\SINGLEFILEINDEX.DONTSPAWN)
(\SFI.LISTFILESEVENT (CREATE.EVENT (QUOTE SINGLEFILEINDEX))))
(VARS (\SFI.FILESTCONC (LIST NIL))
(DEFAULTINDEXEDTYPESLST (SUBST \SFI.INDIRECTION (QUOTE
\SFI.INDIRECTION)
(QUOTE ((MACRO PUTPROPS TestForMacro)
(BITMAP "RPAQ "
TestForBitmap T)
(VAR (RPAQ ADDTOVAR)
TestForVar)
(CONSTANTS CONSTANTS
TestForConstants)
(RECORD (\SFI.INDIRECTION
CLISPRECORDTYPES))
(RESOURCE PUTDEF
TestForResource)
(CLASS "DEFCLASS ")
(INSTANCE DEFINST
TestForInstance)
(METHOD METH TestForMethod)
(GLOBALRESOURCE PUTDEF
TestForGenericDefinition)))))
(INDEXEDTYPESLST DEFAULTINDEXEDTYPESLST))
(GLOBALVARS \SFI.INDIRECTION \SINGLEFILEINDEX.DONTSPAWN \SFI.FILESTCONC
\SFI.LISTFILESEVENT DEFAULTINDEXEDTYPESLST PRINTER)
(COMS (* * "After CAROL, these will be in MACHINEINDEPENDENT.")
(FNS \SFI.LISPSOURCEFILEP \SFI.GETFILEMAP)
(P (COND ((MOVD? (QUOTE \SFI.LISPSOURCEFILEP)
(QUOTE LISPSOURCEFILEP))
(MOVD? (QUOTE \SFI.GETFILEMAP)
(QUOTE GETFILEMAP)))
(T (PUTD (QUOTE \SFI.LISPSOURCEFILEP))
(PUTD (QUOTE \SFI.GETFILEMAP))))))
(COMS (* * "Random functions that ought to go into the system.")
(FNS ILESSCADR UALPHORDERCAR PUTSASSOC PRINTDOTS \SFI.PLURALIZE)
(* *
"FNS which want to go into the system in either FILEPKG or LOADFNS.")
(FNS NDINFILECOMS? \NDINFILECOMS1 \SFI.LOADCOMS \SFI.GETFILVARDEF)
(INITVARS (\SFI.GETDEF.HASH NIL)
(ERRORMESSAGESTREAM T)))
(COMS (* Index printout functions)
(FNS \SFI.CENTERPRINT \SFI.LISTINGHEADER \SFI.BreakLine))
(FNS * FileIndexingFns)
(FNS * TypeFindingFns)
(GLOBALRESOURCES \A&PSTR)
(DECLARE: DONTCOPY (DECLARE: EVAL@COMPILE (MACROS SFIBLKSTRING.INPUT)
(RECORDS TYPESLSTPATTERN)
(CONSTANTS (CR.EOLC 0)
(LF.EOLC 1)
(CRLF.EOLC 2)))
(DECLARE: EVAL@COMPILEWHEN (EQ COMPILEMODE (QUOTE D))
EVAL@LOADWHEN
(EQ (SYSTEMTYPE)
(QUOTE D))
(FILES (LOADCOMP FROM ({ERIS}<LISPCORE>SOURCES>))
FILEIO))
(DECLARE: EVAL@COMPILEWHEN (EQ COMPILEMODE (QUOTE PDP-10))
EVAL@LOADWHEN
(EQ COMPILEMODE (QUOTE PDP-10))
(FILES (SYSLOAD FROM LISPUSERS)
CJSYS)))
(DECLARE: COPYWHEN (NEQ COMPILEMODE (QUOTE D))
(FNS \SFI.UALPHORDER))
(DECLARE: DOCOPY DONTEVAL@LOAD (P (MOVD? (QUOTE LISTFILES1)
(QUOTE OLDLISTFILES1))
(/MOVD (QUOTE SINGLEFILEINDEX)
(QUOTE LISTFILES1))
(SELECTQ (SYSTEMTYPE)
(D (PUTD (QUOTE
\SFI.UALPHORDER)))
(MOVD? (QUOTE \SFI.UALPHORDER)
(QUOTE UALPHORDER)))
(OR (FIXP (GETTOPVAL (QUOTE
LINESPERPAGE)))
(SAVESETQ LINESPERPAGE
(SELECTQ (SYSTEMTYPE)
(D 65)
58)))))
(GLOBALVARS FONTCHANGEFLG DEFAULTFONT PRETTYCOMFONT)))
(* * "Created by Christopher Tong and JonL White, February 1984.")
(* "Temporary kludge patch")
(AND (BOUNDP (QUOTE INDEXEDTYPESLST))
(NULL INDEXEDTYPESLST)
(SETQ INDEXEDTYPESLST (QUOTE NOBIND)))
(RPAQ? PRINTER (SELECTQ (SYSTEMTYPE)
(D (QUOTE {LPT}))
(QUOTE LPT:)))
(RPAQ? RELATIVEINDEXFLG )
(RPAQ? \SFI.INDIRECTION "Indirection Marker")
(RPAQ? \SINGLEFILEINDEX.DONTSPAWN )
(RPAQ? \SFI.LISTFILESEVENT (CREATE.EVENT (QUOTE SINGLEFILEINDEX)))
(RPAQ \SFI.FILESTCONC (LIST NIL))
(RPAQ DEFAULTINDEXEDTYPESLST (SUBST \SFI.INDIRECTION (QUOTE \SFI.INDIRECTION)
(QUOTE ((MACRO PUTPROPS TestForMacro)
(BITMAP "RPAQ " TestForBitmap T)
(VAR (RPAQ ADDTOVAR)
TestForVar)
(CONSTANTS CONSTANTS TestForConstants)
(RECORD (\SFI.INDIRECTION CLISPRECORDTYPES))
(RESOURCE PUTDEF TestForResource)
(CLASS "DEFCLASS ")
(INSTANCE DEFINST TestForInstance)
(METHOD METH TestForMethod)
(GLOBALRESOURCE PUTDEF TestForGenericDefinition)))))
(RPAQ INDEXEDTYPESLST DEFAULTINDEXEDTYPESLST)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \SFI.INDIRECTION \SINGLEFILEINDEX.DONTSPAWN \SFI.FILESTCONC \SFI.LISTFILESEVENT
DEFAULTINDEXEDTYPESLST PRINTER)
)
(* * "After CAROL, these will be in MACHINEINDEPENDENT.")
(DEFINEQ
(\SFI.LISPSOURCEFILEP
(LAMBDA (FILE) (* JonL "10-Mar-84 20:30")
(* * If the first few characters of FILE "look like" those output by MAKEFILE then return the alleged address in
the file of its FILEMAP expression.)
(PROG (MAPADDR (FULL (OPENP FILE)))
(if (AND FULL (NOT (RANDACCESSP FULL)))
then (* Currently we don't handle this -- it could be "faked"
)
(RETURN))
(RESETLST (if FULL
then (RESETSAVE NIL (LIST (QUOTE SETFILEPTR)
FULL
(GETFILEPTR FULL)))
(SETFILEPTR FULL 0)
else (RESETSAVE (SETQ FULL (OPENFILE FILE (QUOTE INPUT)))
(QUOTE (PROGN (CLOSEF? OLDVALUE)))))
(PROG ((ERRORTYPELST (QUOTE ((16 (ERROR!))))))
(DECLARE (SPECVARS ERRORTYPELST))
(* * NLSETQ doesn't suppress the file-closing operation of EOF; ERROR! bombs out with the file left open.)
(NLSETQ (if (AND (EQ (SKIPSEPRS FULL FILERDTBL)
(QUOTE %())
(NOT (find C
in (QUOTE (%( F I L E C R E A T E D % ))
suchthat (NEQ C (READC FULL FILERDTBL)))))
then (SKREAD FULL)
(SKREAD FULL)
(SETQ MAPADDR (READ FULL FILERDTBL))
(if (NOT (ILESSP (OR (FIXP MAPADDR)
MAX.FIXP)
(OR (GETEOFPTR FULL)
MAX.FIXP)))
then (SETQ MAPADDR))))))
(RETURN MAPADDR))))
(\SFI.GETFILEMAP
(LAMBDA (FILE FL) (* JonL " 8-Mar-84 23:31")
(* Value is map for FILE either obtained from the file itself, or from its property list. FILE is full name of
file, and is presumed open. FL is (NAMEFIELD FL T) Note that the fileptr will be set to 0 afterwards.)
(AND USEMAPFLG
((LAMBDA (MAP MAPADDR)
(DECLARE (SPECVARS MAP MAPADDR))
(if (AND FL (EQ FILE (CAR (SETQ MAP (LISTP (GETPROP FL (QUOTE FILEMAP)))))))
then (CADR MAP)
elseif (NOT (OPENP FILE))
then (ERRORX (LIST 13 FILE))
elseif (NOT (RANDACCESSP FILE))
then (* Sorry, we just cant get to the FILEMAP on a non
RANDACCESSP device.)
NIL
else (PROG ((OPOS (GETFILEPTR FILE)))
(SETQ MAP)
(* * Foo the only reason the following is a RESETVARS is that ERRORTYPELST is wrongly a GLOBALVAR in Interlisp-D)
(SETFILEPTR FILE 0)
(PROG ((ERRORTYPELST (QUOTE ((16 (ERROR!))))))
(DECLARE (SPECVARS ERRORTYPELST))
(* * NLSETQ doesn't suppress the file-closing operation of EOF; ERROR! bombs out with the file left open.)
(NLSETQ (if (AND (EQ (SKIPSEPRS FILE FILERDTBL)
(QUOTE %())
(NOT (find C
in (QUOTE (%( F I L E C R E A T E D % ))
suchthat (NEQ C (READC FILE FILERDTBL)))))
then (SKREAD FILE)
(SKREAD FILE)
(SETQ MAPADDR (READ FILE FILERDTBL))
(if (ILESSP (OR (FIXP MAPADDR)
MAX.FIXP)
(OR (GETEOFPTR FILE)
MAX.FIXP))
then (SETFILEPTR FILE MAPADDR)
(SETQ MAP (READ FILE FILERDTBL))))))
(SETFILEPTR FILE OPOS)
(RETURN (AND (EQ (CAR (LISTP MAP))
(QUOTE FILEMAP))
(CADR MAP))))))))))
)
(COND ((MOVD? (QUOTE \SFI.LISPSOURCEFILEP)
(QUOTE LISPSOURCEFILEP))
(MOVD? (QUOTE \SFI.GETFILEMAP)
(QUOTE GETFILEMAP)))
(T (PUTD (QUOTE \SFI.LISPSOURCEFILEP))
(PUTD (QUOTE \SFI.GETFILEMAP))))
(* * "Random functions that ought to go into the system.")
(DEFINEQ
(ILESSCADR
(LAMBDA (I J) (* cht: " 6-JAN-84 01:32")
(AND (CADR I)
(OR (NULL (CADR J))
(ILESSP (CADR I)
(CADR J))))))
(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))))
(PUTSASSOC
(LAMBDA (KEY VAL ALST) (* edited: "12-Feb-84 17:03")
(* * Like PUTASSOC, but uses EQUAL instead of EQ.)
(PROG (newList foundFlg)
(SETQ newList (for item in ALST collect (COND
((AND (NOT foundFlg)
(EQUAL (CAR item)
KEY))
(SETQ foundFlg T)
(CONS (CAR item)
VAL))
(T item))))
(COND
((NOT foundFlg)
(RETURN (APPEND newList (LIST (CONS KEY VAL)))))
(T (RETURN newList))))))
(PRINTDOTS
(LAMBDA (N FILE) (* JonL "10-Mar-84 20:37")
(SELECTQ (SYSTEMTYPE)
((D VAX)
(PROG ((STRM (GETSTREAM FILE (QUOTE OUTPUT))))
(* Dont really need the \OUTCHAR function here since we
won't go more than one line's worth)
(FRPTQ N (BOUT STRM (CHARCODE %.)))))
(PROGN (FRPTQ (IQUOTIENT N 8)
(PRIN1 "........" FILE))
(FRPTQ (IREMAINDER N 8)
(PRIN1 "." FILE))))))
(\SFI.PLURALIZE
(LAMBDA (X) (* JonL "17-May-84 02:02")
(PROG ((LITP (LITATOM X))
LEN SUFFIX)
(OR LITP (STRINGP X)
(LISPERROR X "ARG NOT LITATOM"))
(SETQ SUFFIX (SELCHARQ (NTHCHARCODE X (SETQ LEN (NCHARS X)))
((X S)
"ES")
(H (SELCHARQ (NTHCHARCODE X (SUB1 LEN))
(S "ES")
"S"))
(Y (SETQ X (SUBSTRING X 1 (SUB1 LEN)))
"IES")
"S"))
(SETQ X (CONCAT X SUFFIX))
(RETURN (if LITP
then (MKATOM X)
else X)))))
)
(* * "FNS which want to go into the system in either FILEPKG or LOADFNS.")
(DEFINEQ
(NDINFILECOMS?
(LAMBDA (NAME TYPE FULL COMS MAP items) (* JonL "17-May-84 01:03")
(DECLARE (SPECVARS NAME TYPE FULL MAP items))
(* * Somewhat like INFILECOMS?, except tries to GETDEF on vars in COMS whose defs are not loaded.
ND prefix means "Non-Destructive")
(* * FULL must be the fullname of an open file; COMS should not be null, but MAP can be. "items" is a list onto
which to cons the results when NAME is null.)
(OR (OPENP FULL)
(ERRORX (LIST 13 FULL)))
(if (AND MAP (EQ TYPE (QUOTE FNS)))
then (* This is more general than it need be for now.
Mostly we are calling it with NAME = NIL)
(if (EQ NAME T)
then (AND (CDR MAP)
T)
elseif (NULL NAME)
then (for list in MAP do (for fn in (CDDR list) do (pushnew items (CAR fn))))
items
elseif (find list in MAP suchthat (ASSOC NAME list))
then T)
else (MAPC COMS (FUNCTION \NDINFILECOMS1)) (* \NDINFILECOMS1 will update items with the things it
finds)
(if (NULL NAME)
then items
elseif (NULL items)
then NIL
elseif (OR (EQ NAME T)
(MEMBER NAME items))
then T))))
(\NDINFILECOMS1
(LAMBDA (COM) (* JonL " 3-Oct-84 02:12")
(DECLARE (USEDFREE COMMENTFLG)
(USEDFREE NAME TYPE MAP FULL items))
(if (NLISTP COM)
elseif (EQ (CAR COM)
(QUOTE DECLARE:))
then (PROG ((list COM))
LP (pop list)
(if (NULL list)
then (RETURN)
elseif (NLISTP (CAR list))
then (SELECTQ (CAR list)
((COPYWHEN EVAL@COMPILEWHEN EVAL@LOADWHEN COMPILERVARS)
(* get rid of the conditional or ADDVARS expression.)
(pop list))
NIL)
else (\NDINFILECOMS1 (CAR list)))
(GO LP))
elseif (EQ TYPE (CAR COM))
then (for item TEM in (if (EQ (CADR COM)
(QUOTE *))
then (if (AND (LITATOM (CADDR COM))
(NOT (FMEMB (CADDR COM)
(QUOTE (NIL T)))))
then (* Sorry, can't hack general forms after a *)
(if (EQ TYPE (QUOTE VARS))
then (pushnew items (CADDR COM)))
(\SFI.GETFILVARDEF (CADDR COM)
FULL MAP))
else (CDR COM))
do (if (EQ COMMENTFLG (CAR (LISTP item)))
then (* Note how this permits scattering comments among
definitions in the COMS)
elseif (NOT (MEMBER (SETQ TEM (if (LISTP item)
then (CAR item)
else item))
items))
then (push items TEM)))
elseif (AND (EQ TYPE (QUOTE VARS))
(NEQ COMMENTFLG (CAR COM))
(EQ (CADR COM)
(QUOTE *)))
then (pushnew items (CADDR COM))
elseif (EQ (CAR COM)
(QUOTE COMS))
then (* Don't do this one before the check for filevars !)
(PROG (list fileVar)
(SETQ list (if (EQ (CADR COM)
(QUOTE *))
then (* Note how we can't handle complicated * cases)
(AND (LITATOM (SETQ fileVar (CADDR COM)))
fileVar
(NEQ fileVar T)
(\SFI.GETFILVARDEF fileVar FULL MAP))
else (CDR COM)))
(AND list (SETQ items (NDINFILECOMS? NAME TYPE FULL list MAP items)))))))
(\SFI.LOADCOMS
(LAMBDA (FULL MAP) (* JonL "10-Mar-84 14:50")
(* * FULL is the fullname of an open file; if MAP is non-null, it is the filemap of a LISPSOURCEP file)
(OR (OPENP FULL (QUOTE INPUT))
(ERRORX (LIST 13 FULL)))
(OR (NOT (NULL MAP))
(LISPSOURCEFILEP FULL)
(ERROR FILE "Not a Lisp source file."))
(SETFILEPTR FULL 0)
(PROG (NEWCOMS (COMSNAME (FILECOMS FULL))
(ERRORTYPELST (QUOTE ((16 (ERROR!))))))
(* * NLSETQ doesn't suppress the file-closing operation of EOF; ERROR! bombs out with the file left open.)
(NLSETQ (if (AND (EQ (SKIPSEPRS FULL FILERDTBL)
(QUOTE %())
(NOT (find C
in (QUOTE (%( F I L E C R E A T E D % ))
suchthat (NEQ C (READC FULL FILERDTBL)))))
then (SETFILEPTR FULL 0)
(SKREAD FULL) (* Skips the FILECREATED expression)
(SKREAD FULL) (* Skips the Copyright or PRETTYCOMPRINT expression)
(to 5 do (AND (LISTP (SETQ TEM (READ FULL FILERDTBL)))
(EQ (CAR TEM)
(QUOTE RPAQQ))
(EQ COMSNAME (CAR (LISTP (CDR TEM))))
(RETURN (SETQ NEWCOMS (CADDR TEM)))))))
(RETURN NEWCOMS))))
(\SFI.GETFILVARDEF
(LAMBDA (NAME FULL MAP) (* JonL " 7-Mar-84 16:33")
(DECLARE (USEDFREE \SFI.GETDEF.HASH))
(if (AND NAME (LITATOM NAME))
then
(* * Sorry, can't handle forms like (ADDVARS * (CONS (QUOTE MUMBLE) (LIST SOMEVAR))))
(PROG (VAL)
(if (NLISTP \SFI.GETDEF.HASH)
then (* \SFI.GETDEF.HASH is bound to NIL by SINGLEFILEINDEX1
and MERGEDFILEINDEX1)
(if (EQ \SFI.GETDEF.HASH (QUOTE ERROR))
then (RETURN)
elseif (AND (NULL MAP)
(NOT (LISPSOURCEFILEP FULL)))
then
(* * If there is already a MAP then it probably is a Lisp file but if it isn't a Lisp file at all, then we quash
any further enquiries.)
(SETQ \SFI.GETDEF.HASH (QUOTE ERROR))
(RETURN))
(SETQ \SFI.GETDEF.HASH (LIST (HARRAY 30))))
(if (NULL (SETQ VAL (GETHASH NAME \SFI.GETDEF.HASH)))
then (SETQ VAL (GETDEF NAME (QUOTE VARS)
FULL
(QUOTE NOERROR)))
(PUTHASH NAME (OR VAL \SFI.GETDEF.HASH)
\SFI.GETDEF.HASH)
elseif (EQ VAL \SFI.GETDEF.HASH)
then (* Way to make a NIL entry into the table)
(SETQ VAL))
(RETURN VAL)))))
)
(RPAQ? \SFI.GETDEF.HASH NIL)
(RPAQ? ERRORMESSAGESTREAM T)
(* Index printout functions)
(DEFINEQ
(\SFI.CENTERPRINT
(LAMBDA (STR BOLDFLG DontPrintPageNbrFlg) (* JonL "13-Mar-84 22:07")
(TAB (LRSH (IDIFFERENCE FILELINELENGTH (NCHARS STR))
1))
(if BOLDFLG
then (printout NIL .FONT BOLDFONT STR .FONT DEFAULTFONT)
else (printout NIL STR))
(INDEXNEWLINE DontPrintPageNbrFlg)))
(\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 (* JonL " 6-Nov-84 01:55")
(INDEXNEWLINE T)
(SELECTQ (SYSTEMTYPE)
((D VAX)
(PROG ((STRM (GETSTREAM NIL (QUOTE OUTPUT))))
(* Dont really need the \OUTCHAR function here since we
won't go more than one line's worth)
(FRPTQ FILELINELENGTH (BOUT STRM (CHARCODE ~)))))
(PROGN (FRPTQ (IQUOTIENT N 8)
(PRIN1 "~~~~~~~~"))
(FRPTQ (IREMAINDER N 8)
(PRIN1 "~"))))
(INDEXNEWLINE T)))
)
(RPAQQ FileIndexingFns (SINGLEFILEINDEX \SFI.Q1UP \FILELISTING SINGLEFILEINDEX2 SINGLEFILEINDEX1
\SFI.AnalyzeLine \SFI.FLUSHFONTCHANGE PrintFnDef
PrintOneTypeIndex PrintRelativeFunctionIndex
DetermineLinesPerPage INDEXCOPYBYTES INDEXNEWLINE
INDEXNEWPAGE MERGEDFILEINDEX MERGEDFILEINDEX2
MERGEDFILEINDEX1 PrintFileTitle PrintIndex PrintMergedIndex
\SFI.PrintIndexFactors))
(DEFINEQ
(SINGLEFILEINDEX
(LAMBDA (INF OUTF mergedIndexFlg) (* JonL "28-Dec-84 21:05")
(PROG ((FULL (FINDFILE INF)))
(if (NULL FULL)
then (* When called by LISTFILES INF will already be a full
file name)
(printout (SELECTQ ERRORMESSAGESTREAM
(T PROMPTWINDOW)
ERRORMESSAGESTREAM)
INF " not found." T)
else (RETURN (SELECTQ (SYSTEMTYPE)
(D (if \SINGLEFILEINDEX.DONTSPAWN
then (SINGLEFILEINDEX2 FULL OUTF mergedIndexFlg)
else (\SFI.Q1UP (FUNCTION SINGLEFILEINDEX2)
FULL OUTF mergedIndexFlg)
(* Used to return NIL so that LISTFILES won't try
removing from NOTLISTEDFILES)
FULL))
(SINGLEFILEINDEX2 FULL OUTF mergedIndexFlg)))))))
(\SFI.Q1UP
(LAMBDA (FUN FULL OUTF mergedIndexFlg) (* JonL " 6-Nov-84 00:04")
(TCONC \SFI.FILESTCONC (LIST (FUNCTION SINGLEFILEINDEX2)
FULL OUTF mergedIndexFlg))
(OR (FIND.PROCESS (QUOTE \FILELISTING))
(ADD.PROCESS (QUOTE (\FILELISTING))
(QUOTE BEFOREEXIT)
(QUOTE DON'T)))
(NOTIFY.EVENT \SFI.LISTFILESEVENT)))
(\FILELISTING
(LAMBDA NIL (* JonL "19-Dec-84 04:59")
(RESETSAVE NIL (QUOTE (SELECTQ RESETSTATE ((ERROR RESET)
(SETQ \SFI.FILESTCONC (LIST NIL)))
NIL)))
(PROG (FORM) (* Infinite loop, but don't get fool message from DWIM)
LP (AWAIT.EVENT \SFI.LISTFILESEVENT 20000)
(if (NULL (CAR \SFI.FILESTCONC))
then (DEL.PROCESS (THIS.PROCESS)))
(until (NULL (CAR \SFI.FILESTCONC))
do (APPLY (CAR (SETQ FORM (CAAR \SFI.FILESTCONC)))
(CDR FORM))
(pop (CAR \SFI.FILESTCONC))
(BLOCK)
finally (RPLACD \SFI.FILESTCONC NIL))
(GO LP))))
(SINGLEFILEINDEX2
(LAMBDA (FULL OUTF mergedIndexFlg) (* JonL "28-Dec-84 21:05")
(* SINGLEFILEINDEX should have already computed the
fullname of the input file)
(if (if (SINGLEFILEINDEX1 FULL OUTF mergedIndexFlg)
then (AND (NULL OUTF)
(printout (SELECTQ ERRORMESSAGESTREAM
(T PROMPTWINDOW)
ERRORMESSAGESTREAM)
"indexed version of " FULL " => " PRINTER T))
T
else (if OUTF
then (printout (SELECTQ ERRORMESSAGESTREAM
(T PROMPTWINDOW)
ERRORMESSAGESTREAM)
FULL " is not LISPSOURCEFILEP -- COPYFILE being called" T)
else (OLDLISTFILES1 FULL)))
then (SELECTQ (SYSTEMTYPE)
(D (* Do this here since there is little coordination
between the various multiple processes which are
listing files)
(SETQ NOTLISTEDFILES (REMOVE (ROOTFILENAME FULL)
NOTLISTEDFILES))
NIL)
T))))
(SINGLEFILEINDEX1
(LAMBDA (FULL OUTF mergedIndexFlg) (* JonL "29-Dec-84 09:37")
(* 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 (GLOBALVARS FILERDTBL USEMAPFLG RELATIVEINDEXFLG)
(SPECVARS FULL)
(USEDFREE USEMAPFLG LINESPERPAGE))
(RESETLST (PROG (COMS MAP LINECOUNT PAGECOUNT (LINESPERPAGE LINESPERPAGE)
FULLEOLC FULLS ItemPages typeNames lastPage
(typesLST (AND (OR (NULL RELATIVEINDEXFLG)
(EQ RELATIVEINDEXFLG (QUOTE BOTH)))
INDEXEDTYPESLST))
(\SFI.GETDEF.HASH NIL)
(FNUM 0)
currentItem nextFnGroup nextFnStart FNSMAPSL TEM)
(DECLARE (SPECVARS COMS MAP LINECOUNT PAGECOUNT LINESPERPAGE FULLEOLC FULLS
ItemPages typeNames typesLST \SFI.GETDEF.HASH FNUM currentItem)
(SPECVARS linePos newPos))
(RESETSAVE (SETQ FULL (OPENFILE FULL (QUOTE INPUT)
(QUOTE OLD)))
(QUOTE (PROGN (CLOSEF? OLDVALUE))))
(if (EQ FULL (CAR (SETQ TEM (LISTP (GETP (ROOTFILENAME FULL)
(QUOTE FILEMAP))))))
then (* It appears as though the file has already been
loaded in some way so that the MAP is already loaded)
(SETQ MAP (CADR TEM))
elseif (NULL USEMAPFLG)
then (RESETSAVE NIL (QUOTE (SETTOPVAL USEMAPFLG)))
(SETQ USEMAPFLG T))
(if (OR (AND (NOT (RANDACCESSP FULL))
(OR typesLST (NULL MAP)))
(AND (NULL MAP)
(NULL (SETQ MAP (GETFILEMAP FULL)))
(NOT (LISPSOURCEFILEP FULL))))
then (* 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 PRINTER))
(if (OPENP OUTF (QUOTE OUTPUT))
then (RESETSAVE (OUTPUT (SELECTQ (SYSTEMTYPE)
(D (SETQ OUTF (GETSTREAM OUTF (QUOTE OUTPUT))
))
OUTF)))
else (RESETSAVE (OUTPUT (SETQ OUTF (SELECTQ (SYSTEMTYPE)
(D (OPENSTREAM OUTF (QUOTE OUTPUT)
(QUOTE NEW)))
(OPENFILE OUTF (QUOTE OUTPUT)
(QUOTE NEW)))))
(QUOTE (PROGN (CLOSEF? (OUTPUT OLDVALUE))))))
(RESETSAVE (RADIX 10))
(SETQ LINESPERPAGE (DetermineLinesPerPage FULL OUTF))
(* Determine printing parameters.)
(RESETSAVE (LINELENGTH 1000 OUTF))
(if RELATIVEINDEXFLG
then (PrintFileTitle FULL)
(PrintRelativeFunctionIndex FULL MAP)
elseif (SETQ COMS (\SFI.LOADCOMS FULL MAP))
then (* Make copy of typesLST reducing it by types that
aren't on the COMS)
(SETQ typesLST (for type items in typesLST
when (SETQ items (NDINFILECOMS?
NIL
(OR (SETQ TEM (GETFILEPKGTYPE (CAR type)
NIL T))
(\SFI.PLURALIZE (CAR type)))
FULL COMS MAP (AND TEM (INFILECOMS? NIL TEM
COMS))))
collect (SETQ typeNames (TCONC typeNames
(CONS (CAR type)
items)))
(if (EQ \SFI.INDIRECTION
(CAR (LISTP (fetch typePatterns
of type))))
then
(* De-reference the indirection fields)
(create TYPESLSTPATTERN
typePatterns ←(EVAL
(CADR (fetch typePatterns
of type)))
reusing type)
else type)))
(SETQ typeNames (CAR typeNames)))
(PROGN (SETQ FNSMAPSL (CDR MAP))
(SETQ FULLS FULL)
(SETQ FULLEOLC (SELECTQ (SYSTEMTYPE)
((D VAX)
(SETQ FULLS (GETSTREAM FULL (QUOTE INPUT)))
(fetch EOLCONVENTION of FULLS))
((TENEX TOPS20)
CRLF.EOLC)
(SHOULDNT)))
(SETQ LINECOUNT 1)
(SETQ PAGECOUNT 1)
(SETQ nextFnGroup (CDDR (CAR FNSMAPSL)))
(SETQ nextFnStart (CADAR nextFnGroup)))
(* * Locate and print definitions for each item.)
(bind linePos newPos (currentPos ← 0)
while (SETQ newPos (FFILEPOS (SELECTC FULLEOLC
(CR.EOLC (CONSTANT (CHARACTER
(CHARCODE CR))))
(LF.EOLC (CONSTANT (CHARACTER
(CHARCODE LF))))
(CONSTANT (CONCAT (CHARACTER
(CHARCODE CR))
(CHARACTER
(CHARCODE LF)))))
FULL currentPos))
do (SETFILEPTR FULLS (SETQ linePos currentPos))
(if (if (EQ (PEEKC FULLS)
(CONSTANT (CHARACTER (CHARCODE ↑F))))
then (* Line might start with a fontchange sequence)
(\SFI.FLUSHFONTCHANGE)
(AND nextFnStart (OR (IEQP linePos nextFnStart)
(IEQP currentPos nextFnStart)))
else (AND nextFnStart (IEQP linePos nextFnStart)))
then (* Index and print function group.)
(for function in nextFnGroup do (SETQ newPos (PrintFnDef function))
) (* Should point us at the first of two closing parens)
(pop FNSMAPSL)
(SETQ nextFnGroup (CDDAR FNSMAPSL))
(SETQ nextFnStart (CADAR nextFnGroup))
else (* Print and index (when appropriate) next line.)
(add newPos (SETQ TEM (SELECTC FULLEOLC
(CRLF.EOLC (READC FULLS)
1)
0)))
(if typesLST
then (\SFI.AnalyzeLine FULLS))
(* * Print line.)
(INDEXCOPYBYTES FULLS OUTF currentPos newPos)
(INDEXNEWLINE))
(SETQ currentPos (ADD1 newPos)))
(SETQ lastPage PAGECOUNT)
(* * Print file index or indices.)
(if (OR (NULL RELATIVEINDEXFLG)
(EQ RELATIVEINDEXFLG (QUOTE BOTH)))
then (SETQ ItemPages (SORT ItemPages (FUNCTION UALPHORDERCAR)))
(INDEXNEWPAGE T)
(OR (ODDP PAGECOUNT)
(INDEXNEWPAGE T)) (* Ensure that the index will not be on the back-side
of a two-sided listing)
(PrintFileTitle FULL) (* Create and print index for each type.
Print only one index per type, even when there are
multiple "find" methods for each type.)
(for type in (INTERSECTION (SETQ TEM
(CONS (QUOTE FUNCTION)
(MAPCAR typeNames
(FUNCTION CAR))))
TEM)
do (PrintOneTypeIndex type lastPage))
(\SFI.BreakLine)
(if mergedIndexFlg
then (* Create single merged index for all types.)
(INDEXNEWPAGE T)
(PrintFileTitle FULL)
(PrintMergedIndex ItemPages "TABLE OF CONTENTS")))
(RETURN FULL)))))
(\SFI.AnalyzeLine
(LAMBDA (FULLS FLG) (* JonL "29-Dec-84 10:40")
(* * Retrieve line as string, beginning with first character that isn't a font change char,)
(DECLARE (USEDFREE linePos newPos typesLST ItemPages)
(SPECVARS currentItem))
(SELECTQ (GETSYNTAX (PEEKC FULLS)
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)
(READC FULLS) (* So flush the parens)
(if (EQ (PEEKC FULLS)
(CONSTANT (CHARACTER (CHARCODE ↑F))))
then (* Some places permit the fontchange sequence just
after the open parens!)
(\SFI.FLUSHFONTCHANGE))
(GLOBALRESOURCE
(\A&PSTR)
(PROG ((Nbytes (IDIFFERENCE newPos (GETFILEPTR FULLS))))
(if (ILESSP (NCHARS \A&PSTR)
(IPLUS Nbytes 3))
then (* Extend length of \A&PSTR when needed.)
(SETQ \A&PSTR (ALLOCSTRING (IPLUS Nbytes 3))))
(SFIBLKSTRING.INPUT \A&PSTR Nbytes FULLS)
(* * Stick a couple of extra blanks in after line because \A&PSTR has not been cleared each time and contains junk
from last time.)
(RPLSTRING \A&PSTR (ADD1 Nbytes)
" ")
(* * Record locations and typesLST of each item. Assume item at this particular location only belongs to one type
index.)
(for ENTRY currentItem patStr in typesLST
when (AND (if (LISTP (SETQ patStr (fetch typePatterns of ENTRY)))
then (for atomGuess in patStr
thereis (STRPOS atomGuess \A&PSTR 1 NIL T))
else (STRPOS patStr \A&PSTR 1 NIL T))
(SETQ currentItem
(CAR (NLSETQ (APPLY* (OR (fetch typeTestFN of ENTRY)
(FUNCTION TestForType))
\A&PSTR ENTRY)))))
do (push ItemPages (LIST currentItem (fetch typeName of ENTRY)
PAGECOUNT))
(* When we've finally found a match which isn't
ambiguous, we can quit this loop)
(OR (fetch typeAmbigous? of ENTRY)
(RETURN))))))
((SEPRCHAR) (* Maybe it's the "old" style where the fontchange
character comes before the parens)
(if (AND (NULL FLG)
(EQ (PEEKC FULLS)
(CONSTANT (CHARACTER (CHARCODE ↑F)))))
then (SHOULDNT
"If this ever happens, then LispCore↑ should be notified, and the SHOULDNT in \SFI.AnalyzeLine should be flushed out. MAKEFILE shouldn't put a fontchange character here."
)
(\SFI.FLUSHFONTCHANGE)
(\SFI.AnalyzeLine FULLS T)))
((RIGHTPAREN RIGHTBRACKET) (* Well, some lines will be the closing of a DEFINEQ or
a DECLARE: or whatever)
NIL)
NIL)))
(\SFI.FLUSHFONTCHANGE
(LAMBDA NIL (* JonL " 3-Oct-84 03:29")
(DECLARE (USEDFREE FULLS))
(until (NEQ (PEEKC FULLS)
(CONSTANT (CHARACTER (CHARCODE ↑F))))
do (READC FULLS)
(READC FULLS)
(add linePos 2))))
(PrintFnDef
(LAMBDA (function) (* JonL "28-Feb-84 19:35")
(* * Prints a function definition on the file FULL.)
(PROG (currentItem (currentPos (CADR function))
(newPos (CDDR function)))
(add FNUM 1)
(SETQ currentItem (CAR function))
(INDEXNEWLINE)
(if RELATIVEINDEXFLG
then (printout NIL .SP (IDIFFERENCE FILELINELENGTH (IPLUS 2 (NCHARS FNUM)))
.FONT BOLDFONT "[" FNUM "]" .FONT DEFAULTFONT .RESET))
(INDEXNEWLINE)
(if (NOT (ILEQ (IPLUS LINECOUNT 3)
LINESPERPAGE))
then (INDEXNEWPAGE))
(push ItemPages (LIST currentItem (QUOTE FUNCTION)
PAGECOUNT)) (* Print out function.)
(INDEXCOPYBYTES FULLS OUTF currentPos newPos)
(RETURN newPos))))
(PrintOneTypeIndex
(LAMBDA (type LastPageNo) (* JonL "14-Mar-84 03:18")
(* * Create and print index for a particular datatype.)
(DECLARE (USEDFREE FULL COMS MAP ItemPages))
(PROG ((IndexedList (for triple in ItemPages when (EQ type (CADR triple))
collect (CONS (CAR triple)
(CADDR triple)))))
(* * Create indexed list. A "triple" is a list of a definitional NAME and TYPE and PAGENUMBER)
(if IndexedList
then (* Print type index title.)
(PrintIndex (SORT IndexedList (FUNCTION UALPHORDERCAR))
LastPageNo type)
(INDEXNEWLINE T)
elseif (AND (EQ type (QUOTE FUNCTION))
COMS
(NULL MAP)
(NDINFILECOMS? NIL (QUOTE FNS)
FULL COMS NIL (INFILECOMS? NIL (QUOTE FNS)
COMS)))
then (* Well, there were FNS on the file, but we didn't find
them!)
(INDEXNEWLINE T)
(\SFI.CENTERPRINT "No FUNCTION indexing because FILEMAP not found" NIL T)))))
(PrintRelativeFunctionIndex
(LAMBDA (FULL MAP) (* JonL "14-Mar-84 03:13")
(* * Create and print an index for the functions on the file.)
(PROG (currentItem IndexedList (MaxIndexNo 0))
(SETQ IndexedList (for DFQ in MAP join (for function in (CDDR DFQ)
collect (CONS (CAR function)
(add MaxIndexNo 1)))))
(* Printout function index.)
(if (NOT IndexedList)
then (INDEXNEWLINE T)
(INDEXNEWLINE T)
(printout NIL .FONT BOLDFONT "No Functions." .FONT DEFAULTFONT)
else (PrintIndex IndexedList MaxIndexNo))
(INDEXNEWPAGE T)
(RETURN MAP))))
(DetermineLinesPerPage
(LAMBDA (FULL OUTF) (* cht: "18-Feb-84 12:38")
(PROG ((LINESPERPAGE LINESPERPAGE))
(SELECTQ (SYSTEMTYPE)
(TENEX (COND
((STRPOS "PARC-MAXC" (HOSTNAME))
(PROG ((J (VAG (OPNJFN OUTF))))
(ASSEMBLE NIL (* Set the "NAME" parameter to be the name of the file)
(CQ (CONCAT FULL (CHARACTER 0)))
(FASTCALL UPATM)
(PUSHN 3)
(CQ (CONSTANT (CONCAT "NAME" (CHARACTER 0))))
(FASTCALL UPATM)
(MOVE 2 , 3)
(POPN 3)
(CQ J)
(JSYS 440Q)
(JFCL))
(SETQ LINESPERPAGE (IDIFFERENCE (BITS 4 10 (JS RFMOD
(LOC J)
NIL NIL 2))
3))))))
(D (SETQ LINESPERPAGE (OR (GETFILEINFO OUTF (QUOTE PAGEHEIGHT))
LINESPERPAGE)))
NIL)
(RETURN LINESPERPAGE))))
(INDEXCOPYBYTES
(LAMBDA (IN OUT START END) (* JonL "25-Feb-84 18:25")
(* 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)
(SELECTQ (SYSTEMTYPE)
((TENEX TOPS20)
(PROG ((IJFN (VAG (OPNJFN IN)))
(OJFN (VAG (OPNJFN OUT)))
NLFLG CH) (* This doesn't really handle EOL conventions properly)
(FRPTQ (IDIFFERENCE END START)
(SELCHARQ (SETQ CH (JS BIN (LOC IJFN)
NIL NIL 2))
(CR (* leave NLFLG)
(JS BOUT (LOC OJFN)
(CHARCODE CR)
NIL 2))
(LF (JS BOUT (LOC OJFN)
(CHARCODE LF)
NIL 2)
(COND
((AND NLFLG (IGREATERP LINECOUNT (IDIFFERENCE
LINESPERPAGE 5)))
(* double cr near end of page)
(INDEXNEWPAGE))
(T (COND
((IGREATERP (add LINECOUNT 1)
LINESPERPAGE)
(INDEXNEWPAGE)))
(SETQ NLFLG T))))
(FF (INDEXNEWPAGE)
(SETQ NLFLG NIL))
(PROGN (JS BOUT (LOC OJFN)
CH NIL 2)
(SETQ NLFLG NIL))))))
((D VAX)
(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))))))
(HELP))
T))
(INDEXNEWLINE
(LAMBDA (DontPrintPageNbrFlg) (* JonL "13-Mar-84 22:04")
(TERPRI)
(if (IGREATERP (add LINECOUNT 1)
LINESPERPAGE)
then (INDEXNEWPAGE DontPrintPageNbrFlg))))
(INDEXNEWPAGE
(LAMBDA (DontPrintPageNbrFlg) (* JonL "13-Mar-84 22:04")
(PRIN3 (FCHARACTER (CHARCODE FF)))
(POSITION NIL 0)
(SETQ LINECOUNT 0)
(if PAGECOUNT
then (add PAGECOUNT 1))
(\SFI.LISTINGHEADER DontPrintPageNbrFlg)))
(MERGEDFILEINDEX
(LAMBDA (FILES OUTF) (* JonL " 5-Nov-84 23:53")
(* Note how we collect assurance that the files exist before exiting this process -- this is to insure that the
right defaults are used for connected directory.)
(SETQ FILES (for file file1 FULLNAMES in (MKLIST FILES)
eachtime (OR (SETQ file1 (FINDFILE file))
(PROMPTPRINT (CONCAT "File " file " not found.")))
when file1 collect file1))
(SELECTQ (SYSTEMTYPE)
(D (if \SINGLEFILEINDEX.DONTSPAWN
then (MERGEDFILEINDEX2 FILES OUTF)
else (\SFI.Q1UP (FUNCTION MERGEDFILEINDEX2)
FILES OUTF) (* Used to return NIL so that LISTFILES won't try
removing from NOTLISTEDFILES)
FULL))
(MERGEDFILEINDEX2 FILES OUTF))
FILES))
(MERGEDFILEINDEX2
(LAMBDA (FILES OUTF) (* JonL " 5-Nov-84 23:53")
(MERGEDFILEINDEX1 FILES (OR OUTF PRINTER))))
(MERGEDFILEINDEX1
(LAMBDA (FILES OUTF) (* JonL " 3-Jun-84 18:37")
(* * Makes a single index to a set of files. The index is a table of contents which lists all the functions and
classes in alphabetical order, and a fileName -
sequence number pair for where that function or class is in the file.)
(* * FILES must be a non-null list of fullnames)
(DECLARE (GLOBALVARS FILERDTBL USEMAPFLG)
(USEDFREE LINESPERPAGE USEMAPFLG))
(PROG (currentItem FULL (LINESPERPAGE LINESPERPAGE)
(LINECOUNT 0)
(PAGECOUNT 0)
(\SFI.GETDEF.HASH NIL)
(types INDEXEDTYPESLST)
IndexedList DATE)
(DECLARE (SPECVARS currentItem FULL LINESPERPAGE LINECOUNT PAGECOUNT \SFI.GETDEF.HASH)
(SPECVARS ROOT COMS MAP))
(RESETSAVE (OUTFILE OUTF)
(QUOTE (PROGN (CLOSEF? (OUTPUT OLDVALUE)))))
(RESETSAVE (LINELENGTH 1000))
(RESETSAVE (RADIX 10))
(if (NULL USEMAPFLG)
then (RESETSAVE NIL (QUOTE (SETTOPVAL USEMAPFLG)))
(SETQ USEMAPFLG T)) (* Create index of indexed files.)
(PROGN (\SFI.CENTERPRINT "Indexed Files" T T)
(\SFI.CENTERPRINT (CONCAT "-- Listed on " (DATE)
" --")
NIL T)
(INDEXNEWLINE T)
(for FN in FILES
do (SETQ DATE (GETFILEINFO FN (QUOTE WRITEDATE)))
(INDEXNEWLINE T)
(PRIN1 FN)
(PRINTDOTS (IDIFFERENCE FILELINELENGTH (IPLUS 4 (NCHARS FN)
(NCHARS DATE))))
(PRIN1 DATE))
(INDEXNEWPAGE T)) (* Index all types.)
(for file ROOT COMS MAP in FILES
do (RESETSAVE (SETQ FULL (OPENFILE file (QUOTE INPUT)
(QUOTE OLD)))
(QUOTE (PROGN (CLOSEF? OLDVALUE))))
(SETQ MAP (GETFILEMAP FULL (SETQ ROOT (ROOTFILENAME FULL))))
(* * Note subsequent call to \SFI.GETFILVARDEF and that FindTypeItems also calls NDINFILECOMS?)
(SETQ \SFI.GETDEF.HASH)
(if (SETQ COMS (\SFI.LOADCOMS FULL MAP))
then (for typePair type filepkgtypeP ignoreables in (CONS (QUOTE (FNS))
types)
do (SETQ type (OR (SETQ filepkgtypeP (GETFILEPKGTYPE (CAR typePair)
NIL T))
(\SFI.PLURALIZE (CAR typePair))))
(* hack that removes instances that are methods.)
(SETQ ignoreables (SELECTQ type
(INSTANCES
(NDINFILECOMS?
NIL
(QUOTE METHODS)
FULL COMS MAP
(AND (GETFILEPKGTYPE (QUOTE METHODS)
NIL T)
(INFILECOMS? NIL (QUOTE METHODS)
COMS))))
NIL))
(for item in (NDINFILECOMS? NIL type FULL COMS MAP
(AND filepkgtypeP (INFILECOMS? NIL type
COMS)))
when (NOT (MEMBER item ignoreables))
do (push IndexedList (LIST item type ROOT)))))
(CLOSEF? FULL))
(PrintMergedIndex (SORT IndexedList (FUNCTION UALPHORDERCAR)))
(RETURN FILES))))
(PrintFileTitle
(LAMBDA (file) (* JonL "17-Mar-84 15:05")
(* Print file title.)
(* Should not be called unless file is essentially
"at the top of the page")
(\SFI.CENTERPRINT (CONCAT file " " (GETFILEINFO file (QUOTE WRITEDATE)))
T)
(\SFI.CENTERPRINT (CONCAT "-- Listed on " (DATE)
" --"))
(INDEXNEWLINE)))
(PrintIndex
(LAMBDA (IndexedList MaxIndexNo type) (* JonL " 9-Apr-84 16:24")
(* * print index of items in IndexedList.)
(DECLARE (USEDFREE LINESPERPAGE LINECOUNT))
(PROG (NCOLUMNS NROWS WIDTH LEFT SPACING NROWSREMAINING LastItem)
(DECLARE (SPECVARS NCOLUMNS LEFT WIDTH SPACING NROWS))
(SETQ WIDTH (IPLUS (for triple (MAXFWIDTH ← 0) in IndexedList
do (SETQ MAXFWIDTH (IMAX MAXFWIDTH (NCHARS (CAR triple))))
finally (RETURN MAXFWIDTH))
(if (ILESSP MaxIndexNo 10)
then 2
elseif (ILESSP MaxIndexNo 100)
then 3
else (ADD1 (NCHARS MaxIndexNo)))))
(\SFI.PrintIndexFactors IndexedList)
(SETQ NROWSREMAINING NROWS)
(AND type (\SFI.BreakLine)) (* When type is non-null, call is from
PrintOneTypeIndex)
(INDEXNEWLINE T)
(if type
then (if (AND (IGREATERP (IPLUS NROWS 3)
(IDIFFERENCE LINESPERPAGE LINECOUNT))
(IGREATERP LINECOUNT (LRSH LINESPERPAGE 1)))
then
(* * Don't start an indexing on the bottom half of a page which is going to cross a page coundary before the
"breaker")
(INDEXNEWPAGE T)
(AND type (\SFI.BreakLine)))
(\SFI.CENTERPRINT (CONCAT type " INDEX")
T T)
(INDEXNEWLINE T))
(while IndexedList
do (SETQ NROWS (IMIN NROWSREMAINING (IDIFFERENCE LINESPERPAGE LINECOUNT)))
(for ROW from 1 to NROWS
do (for COLUMN from 1 to NCOLUMNS
do (if (SETQ LastItem (FNTH IndexedList (IPLUS ROW (ITIMES NROWS
(SUB1 COLUMN)))))
then (printout NIL .FONT DEFAULTFONT (CAAR LastItem))
(PRINTDOTS (IDIFFERENCE (IDIFFERENCE WIDTH (NCHARS (CAAR
LastItem)))
(NCHARS (CDAR LastItem))))
(PRIN1 (CDAR LastItem))
(if (NEQ COLUMN NCOLUMNS)
then (SPACES SPACING))))
(INDEXNEWLINE T))
(if (SETQ IndexedList (CDR LastItem))
then (INDEXNEWPAGE T)
(SETQ NROWSREMAINING (ADD1 (IQUOTIENT (LENGTH IndexedList)
NCOLUMNS))))))))
(PrintMergedIndex
(LAMBDA (IndexedList title) (* JonL " 3-Oct-84 01:58")
(* Makes an index to a set of files which have been printed by SINGLEFILEINDEX. The index is a table of contents
which lists all the functions in alphabetical order, and a fileName -
sequence number pair for where that function is in the file.)
(DECLARE (USEDFREE LINECOUNT LINSEPERPAGE FILELINELENGTH))
(PROG ((FULL NIL)
(currentItem NIL)
(WIDTH 0)
(MAXFWIDTH 0)
(MAXTWOFIELDWIDTH 0)
item type file index NCOLUMNS NROWS LEFT SPACING LastItem)
(DECLARE (SPECVARS FULL currentItem NCOLUMNS LEFT WIDTH SPACING NROWS))
(\SFI.CENTERPRINT (OR title "MERGED INDEX")
T T)
(INDEXNEWLINE T)
(if (NULL IndexedList)
then (INDEXNEWLINE T)
(printout NIL .FONT BOLDFONT "No printable definitions." .FONT DEFAULTFONT)
(INDEXNEWPAGE T)
(RETURN)
else (for old item in IndexedList
do (SETQ MAXFWIDTH (IMAX MAXFWIDTH (NCHARS (CAR item))))
(SETQ MAXTWOFIELDWIDTH (IMAX MAXTWOFIELDWIDTH (IPLUS MAXFWIDTH
(NCHARS (CADR item)))))
(SETQ WIDTH (IMAX WIDTH (IPLUS MAXTWOFIELDWIDTH (NCHARS (CADDR item)))))))
(add MAXTWOFIELDWIDTH 2)
(add WIDTH 6)
(\SFI.PrintIndexFactors IndexedList)
(SETQ NROWS (IMIN NROWS (IDIFFERENCE LINESPERPAGE LINECOUNT)))
(while IndexedList
do (for ROW from 1 to NROWS
do (for COLUMN from 1 to NCOLUMNS
do (if (SETQ LastItem (FNTH IndexedList (IPLUS ROW (ITIMES NROWS
(SUB1 COLUMN)))))
then (SETQ item (CAAR LastItem))
(SETQ type (CADAR LastItem))
(SETQ file (CADDAR LastItem))
(PRIN1 item) (* Right justify printing of type field.)
(PRINTDOTS (IDIFFERENCE MAXTWOFIELDWIDTH (IPLUS (NCHARS item)
(NCHARS type))))
(PRIN1 type) (* Right justify printing of file field.)
(PRINTDOTS (IDIFFERENCE WIDTH (IPLUS MAXTWOFIELDWIDTH
(NCHARS file))))
(PRIN1 file)
(if (NEQ COLUMN NCOLUMNS)
then (SPACES SPACING))))
(INDEXNEWLINE T))
(if (SETQ IndexedList (CDR LastItem))
then (INDEXNEWPAGE T)))
(RETURN))))
(\SFI.PrintIndexFactors
(LAMBDA (IndexedList) (* JonL "26-Mar-84 16:48")
(DECLARE (USEDFREE NCOLUMNS LEFT WIDTH SPACING NROWS))
(PROG ((LEN (LENGTH IndexedList)))
(SETQ NCOLUMNS (IMAX 1 (IMIN LEN (IQUOTIENT FILELINELENGTH (IPLUS WIDTH 2)))))
(SETQ LEFT (IDIFFERENCE FILELINELENGTH (ITIMES (IPLUS WIDTH 2)
NCOLUMNS)))
(* LEFT is number of spaces remaining.)
(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 (if (EQ NCOLUMNS 1)
then 0
else (IQUOTIENT (IDIFFERENCE FILELINELENGTH (ITIMES WIDTH NCOLUMNS))
(SUB1 NCOLUMNS))))
(SETQ NROWS (ADD1 (IQUOTIENT LEN NCOLUMNS))))))
)
(RPAQQ TypeFindingFns (TestForVar TestForMacro TestForBitmap TestForResource TestForGenericDefinition
TestForConstants TestForInstance TestForMethod TestForType
PositionForTest))
(DEFINEQ
(TestForVar
(LAMBDA (line typesLstTriple) (* JonL " 3-Jun-84 18:35")
(PROG (newVarName (strm (PositionForTest line)))
(* * Search for line defining type. Make sure the line appears in a legitimate definition.)
(if (FMEMB (SETQ newVarName (READ strm FILERDTBL))
(QUOTE (GLOBALVARS SPECVARS LOCALVARS NLAMA NLAML LAMA)))
then (RETURN NIL)
elseif (FMEMB newVarName (CDR (FASSOC (CAR typesLstTriple)
typeNames)))
then
(* * Note that VARS names must be litatoms, and that type names must be litatoms too.)
(if (NOT (FMEMB newVarName (CDR (FASSOC (QUOTE CONSTANTS)
typeNames))))
then (* Flush out the names which are really symbolic
constants.)
(RETURN newVarName))
elseif (OR (NOT (LITATOM newVarName))
(NULL newVarName)
(EQ newVarName T))
then (SHOULDNT)))))
(TestForMacro
(LAMBDA (line typesLstTriple) (* JonL " 3-Jun-84 18:36")
(* * Determine name of current macro, and locate next macro.)
(PROG (newMacroName propName (strm (PositionForTest line)))
(* * Cycle through PUTPROPS until one with a property name of "MACRO" is found.)
(SETQ newMacroName (READ strm FILERDTBL))
(SETQ propName (READ strm FILERDTBL))
(AND (FMEMB propName MACROPROPS)
(FMEMB newMacroName (CDR (FASSOC (QUOTE MACRO)
typeNames)))
(RETURN newMacroName)))))
(TestForBitmap
(LAMBDA (line typesLstTriple) (* JonL " 6-Nov-84 01:58")
(PROG (newVarName char (strm (PositionForTest line))) (* Find first seperator characters after matched
string.)
(* Should have skipped over a RPAQ and then found the
VARS name for this bitmap)
(if (AND (LITATOM (SETQ newVarName (READ strm FILERDTBL)))
newVarName
(LITATOM (SETQ char (RATOM strm FILERDTBL)))
(EQ 1 (NCHARS char))
(FMEMB (GETSYNTAX char FILERDTBL)
(QUOTE (LEFTPAREN LEFTBRACKET)))
(EQ (RATOM strm FILERDTBL)
(QUOTE READBITMAP)))
then (* After the VARS name is the form
(READBITMAP ...))
(RETURN newVarName)))))
(TestForResource
(LAMBDA (line typesLstTriple) (* JonL " 5-Nov-84 23:11")
(OR (FMEMB (CAR typesLstTriple)
(QUOTE (GLOBALRESOURCE RESOURCE)))
(SHOULDNT))
(OR (TestForGenericDefinition line (QUOTE (RESOURCE)))
(TestForGenericDefinition line (QUOTE (GLOBALRESOURCE))))))
(TestForGenericDefinition
(LAMBDA (line typesLstTriple) (* JonL " 3-Jun-84 18:33")
(PROG (DefName FORM ONFILETYPE (strm (PositionForTest line))
(ENTRYTYPE (CAR typesLstTriple))) (* Find first seperator characters after matched
string.)
(OR (EQ (QUOTE QUOTE)
(CAR (LISTP (SETQ DefName (READ strm FILERDTBL)))))
(RETURN)) (* Should have skipped over a PUTDEF and then found the
(QUOTE mumble))
(SETFILEPTR FULLS (PROG1 (GETFILEPTR FULLS)
(SETQ FORM (READ FULLS FILERDTBL))))
(OR (EQ (QUOTE QUOTE)
(CAR (LISTP FORM)))
(RETURN)) (* Should now have found the
(QUOTE <TYPENAME>))
(SETQ ONFILETYPE (CAR (LISTP (CDR FORM))))
(if (OR (EQ ONFILETYPE ENTRYTYPE)
(EQ ONFILETYPE (OR (GETFILEPKGTYPE ENTRYTYPE NIL T)
(\SFI.PLURALIZE ENTRYTYPE))))
then (RETURN (CADR DefName))))))
(TestForConstants
(LAMBDA (line typesLstTriple) (* JonL " 3-Jun-84 18:34")
(* Note that this always returns NIL)
(PROG (FORM)
(SETFILEPTR FULLS (PROG1 (GETFILEPTR FULLS)
(SETFILEPTR FULLS linePos)
(SETQ FORM (READ FULLS FILERDTBL))))
(if (EQ (CAR (LISTP FORM))
(QUOTE CONSTANTS))
then (MAPC (CDR FORM)
(FUNCTION (LAMBDA (X)
(if (LISTP X)
then (SETQ X (CAR X)))
(if (AND X (LITATOM X))
then (push ItemPages (LIST X (QUOTE CONSTANTS)
PAGECOUNT))))))))))
(TestForInstance
(LAMBDA (line typesLstTriple) (* JonL " 3-Jun-84 18:35")
(PROG (newInstanceName className (instanceNames (CDR (FASSOC (CAR typesLstTriple)
typeNames)))
(strm (PositionForTest line))) (* Note: Method instances will not be listed as they are
not printed on the file with "DEFINST")
(SETQ className (READ strm FILERDTBL))
(OR (FMEMB (GETSYNTAX (RATOM strm FILERDTBL)
FILERDTBL)
(QUOTE (LEFTPAREN LEFTBRACKET)))
(RETURN))
(if (MEMBER (SETQ newInstanceName (READ strm FILERDTBL))
instanceNames)
then (RETURN newInstanceName)))))
(TestForMethod
(LAMBDA (line typesLstTriple) (* JonL " 3-Jun-84 18:36")
(PROG (newMethodName (strm (PositionForTest line)))
(* * Locate next bona fide method.)
(COND
((FMEMB (SETQ newMethodName (PACK* (RATOM strm FILERDTBL)
"."
(RATOM strm FILERDTBL)))
(FASSOC (QUOTE METHOD)
typeNames))
(RETURN newMethodName))))))
(TestForType
(LAMBDA (line typesLstTriple) (* JonL " 3-Jun-84 18:36")
(PROG (newItemName (strm (PositionForTest line))
(itemNames (CDR (FASSOC (CAR typesLstTriple)
typeNames))))
(* * Search for line defining type. Make sure the line appears in a legitimate definition.)
(SETQ newItemName (READ strm FILERDTBL))
(if (MEMBER newItemName itemNames)
then (RETURN newItemName)))))
(PositionForTest
(LAMBDA (line) (* JonL "28-Feb-84 18:08")
(* "line" is a line of characters from a file, expressed
as a STRINGP)
(PROG ((strm (SELECTQ (SYSTEMTYPE)
(D (OPENSTRINGSTREAM line))
line)))
(until (NOT (FMEMB (GETSYNTAX (READC strm)
FILERDTBL)
(QUOTE (SEPRCHAR LEFTPAREN RIGHTPAREN LEFTBRACKET RIGHTBRACKET BREAKCHAR)
))))
(SKREAD strm)
(RETURN strm))))
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTDEF (QUOTE \A&PSTR)
(QUOTE RESOURCES)
(QUOTE (NEW (ALLOCSTRING 100))))
)
)
(/SETTOPVAL (QUOTE \\A&PSTR.GLOBALRESOURCE))
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(DECLARE: EVAL@COMPILE
(PUTPROPS SFIBLKSTRING.INPUT MACRO (OPENLAMBDA (STR N FILE)
(for I to N do (RPLCHARCODE STR I (CHCON1 (READC FILE))) -)))
(PUTPROPS SFIBLKSTRING.INPUT DMACRO ((STR N FILE)
(AIN STR 1 N FILE)))
)
[DECLARE: EVAL@COMPILE
(RECORD TYPESLSTPATTERN (typeName typePatterns typeTestFN typeAmbigous?))
]
(DECLARE: EVAL@COMPILE
(RPAQQ CR.EOLC 0)
(RPAQQ LF.EOLC 1)
(RPAQQ CRLF.EOLC 2)
(CONSTANTS (CR.EOLC 0)
(LF.EOLC 1)
(CRLF.EOLC 2))
)
)
(DECLARE: EVAL@COMPILEWHEN (EQ COMPILEMODE (QUOTE D)) EVAL@LOADWHEN (EQ (SYSTEMTYPE)
(QUOTE D))
(FILESLOAD (LOADCOMP FROM ({ERIS}<LISPCORE>SOURCES>))
FILEIO)
)
(DECLARE: EVAL@COMPILEWHEN (EQ COMPILEMODE (QUOTE PDP-10)) EVAL@LOADWHEN (EQ COMPILEMODE
(QUOTE PDP-10))
(FILESLOAD (SYSLOAD FROM LISPUSERS)
CJSYS)
)
)
(DECLARE: COPYWHEN (NEQ COMPILEMODE (QUOTE D))
(DEFINEQ
(\SFI.UALPHORDER
(LAMBDA (X Y) (* JonL "27-Feb-84 23:36")
(SELECTQ (SYSTEMTYPE)
((TENEX TOPS20)
(ASSEMBLE NIL
(CQ X)
(HLRZ 1 , 2 (1))
(FASTCALL UPATM)
(PUSHNN (3)
(4))
(CQ Y)
(HLRZ 1 , 2 (1))
(FASTCALL UPATM)
(NREF (MOVE 5 , -1))
(NREF (MOVE 6 , 0))
(POPNN 2)
(* At last the basic alphabetizer. Ac6 has NCHARS A; ac5 has byte pointer to A; ac4 has NCHARS
(CAR B) (from this call to UPATM), ac3 has byte pointer to B.)
LP (SOJL 6 , SUCCEED) (* (CAR A) won because shorter)
(SOJL 4 , FAIL) (* (CAR B) won because shorter.)
(ILDB 1 , 5)
(CAIL 1 , (CHCON1 (QUOTE a)))
(CAILE 1 , (CHCON1 (QUOTE z)))
(SKIPA)
(SUBI 1 , 40Q)
(ILDB 2 , 3)
(CAIL 2 , (CHCON1 (QUOTE a)))
(CAILE 2 , (CHCON1 (QUOTE z)))
(SKIPA)
(SUBI 2 , 40Q)
(CAMN 1 , 2)
(JRST LP) (* Chars the same, try again.)
(CAML 1 , 2) (* (CAR A) and (CAR B) have different spellings.
Compare magnitude of character byte and exit with
result.)
FAIL(SKIPA 1 , KNIL)
SUCCEED
(HRRZ 1 , KT)))
(ALPHORDER (U-CASE X)
(U-CASE Y)))))
)
)
(DECLARE: DOCOPY DONTEVAL@LOAD
(MOVD? (QUOTE LISTFILES1)
(QUOTE OLDLISTFILES1))
(/MOVD (QUOTE SINGLEFILEINDEX)
(QUOTE LISTFILES1))
(SELECTQ (SYSTEMTYPE)
(D (PUTD (QUOTE \SFI.UALPHORDER)))
(MOVD? (QUOTE \SFI.UALPHORDER)
(QUOTE UALPHORDER)))
(OR (FIXP (GETTOPVAL (QUOTE LINESPERPAGE)))
(SAVESETQ LINESPERPAGE (SELECTQ (SYSTEMTYPE)
(D 65)
58)))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS FONTCHANGEFLG DEFAULTFONT PRETTYCOMFONT)
)
(PUTPROPS SINGLEFILEINDEX COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (5411 8906 (\SFI.LISPSOURCEFILEP 5421 . 6953) (\SFI.GETFILEMAP 6955 . 8904)) (9193 11400
(ILESSCADR 9203 . 9393) (UALPHORDERCAR 9395 . 9683) (PUTSASSOC 9685 . 10253) (PRINTDOTS 10255 . 10802
) (\SFI.PLURALIZE 10804 . 11398)) (11482 18224 (NDINFILECOMS? 11492 . 12894) (\NDINFILECOMS1 12896 .
15537) (\SFI.LOADCOMS 15539 . 16822) (\SFI.GETFILVARDEF 16824 . 18222)) (18330 19920 (\SFI.CENTERPRINT
18340 . 18692) (\SFI.LISTINGHEADER 18694 . 19254) (\SFI.BreakLine 19256 . 19918)) (20334 54308 (
SINGLEFILEINDEX 20344 . 21321) (\SFI.Q1UP 21323 . 21741) (\FILELISTING 21743 . 22572) (
SINGLEFILEINDEX2 22574 . 23713) (SINGLEFILEINDEX1 23715 . 31809) (\SFI.AnalyzeLine 31811 . 35135) (
\SFI.FLUSHFONTCHANGE 35137 . 35466) (PrintFnDef 35468 . 36369) (PrintOneTypeIndex 36371 . 37548) (
PrintRelativeFunctionIndex 37550 . 38359) (DetermineLinesPerPage 38361 . 39292) (INDEXCOPYBYTES 39294
. 42951) (INDEXNEWLINE 42953 . 43191) (INDEXNEWPAGE 43193 . 43491) (MERGEDFILEINDEX 43493 . 44424) (
MERGEDFILEINDEX2 44426 . 44596) (MERGEDFILEINDEX1 44598 . 47804) (PrintFileTitle 47806 . 48355) (
PrintIndex 48357 . 50662) (PrintMergedIndex 50664 . 53328) (\SFI.PrintIndexFactors 53330 . 54306)) (
54507 61426 (TestForVar 54517 . 55544) (TestForMacro 55546 . 56151) (TestForBitmap 56153 . 57103) (
TestForResource 57105 . 57469) (TestForGenericDefinition 57471 . 58544) (TestForConstants 58546 .
59219) (TestForInstance 59221 . 59917) (TestForMethod 59919 . 60357) (TestForType 60359 . 60854) (
PositionForTest 60856 . 61424)) (62574 64101 (\SFI.UALPHORDER 62584 . 64099)))))
STOP