(FILECREATED " 6-Jun-85 17:02:22" {ERIS}<LISPCORE>LIBRARY>MSHASH.;5 37839
changes to: (MACROS BOGUSVAL BOGUSVALP)
(VARS MSHASHCOMS MSHFNS)
(RECORDS HFTABLE)
(FNS HFGETTABLE HFMAKETABLE HFMAPTABLE HFTESTTABLE HFEQMEMBTABLE HFSTORETABLE
HFPUTTABLE HFADDTABLE HFSUBTABLE LOCALFNP MSKEY FORWARDTABLE MSVAL
NEXTHASHKEY STOREHASHVALUE GETHASHTABLE ANALYZEFILES BUILDDB COPYDB FLUSHDB
EQLST HFGETARGS MSFILECHECK MSFILES RESTOREDB SETDB UPDATECONTAINS UPDATEDB
MSHASHWHENCLOSE)
previous date: " 5-Jun-85 22:29:21" {ERIS}<LISPCORE>LIBRARY>MSHASH.;4)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT MSHASHCOMS)
(RPAQQ MSHASHCOMS [(VARS MSHFNS)
[DECLARE: FIRST (P * (MAPCAR MSHFNS (FUNCTION (LAMBDA (X)
(LIST (QUOTE MOVD?)
(KWOTE (CADR X))
(KWOTE (CADDR X]
(FNS * (MAPCAR MSHFNS (FUNCTION CAR)))
(FNS LOCALFNP MSKEY FORWARDTABLE MSVAL NEXTHASHKEY STOREHASHVALUE GETHASHTABLE)
(INITVARS MSHASHFILE MSREADONLYFLG NEXTHASHKEY MSFILETABLE (MSHASHSCRATCHSTRING
(ALLOCSTRING 255)))
(GLOBALVARS MSHASHFILE MSREADONLYFLG MSFILETABLE NEXTHASHKEY MSHASHSCRATCHSTRING
MSHFNS)
(GLOBALVARS MSDATABASELST MSDBEMPTY LOADDBFLG FILERDTBL)
(DECLARE: DONTCOPY (RECORDS HFTABLE HashTextPtr)
(* HashTextPtr is actually stolen from the new HASH)
(MACROS BOGUSVAL BOGUSVALP))
(FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
HASH)
(LOCALVARS . T)
(FNS ANALYZEFILES BUILDDB COPYDB FLUSHDB EQLST HFGETARGS MSFILECHECK MSFILES
RESTOREDB SETDB UPDATECONTAINS UPDATEDB MSHASHWHENCLOSE)
(COMS (* (ADDVARS (ANALYZEUSERFNS HFGETARGS])
(RPAQQ MSHFNS ((HFGETTABLE GETTABLE OLDHASHGETTABLE)
(HFMAKETABLE MAKETABLE OLDHASHMAKETABLE)
(HFMAPTABLE MAPTABLE OLDHASHMAPTABLE)
(HFTESTTABLE TESTTABLE OLDHASHTESTTABLE)
(HFEQMEMBTABLE EQMEMBTABLE OLDHASHEQMEMBTABLE)
(HFSTORETABLE STORETABLE OLDHASHSTORETABLE)
(HFPUTTABLE PUTTABLE OLDHASHPUTTABLE)
(HFADDTABLE ADDTABLE OLDHASHADDTABLE)
(HFSUBTABLE SUBTABLE OLDHASHSUBTABLE)))
(DECLARE: FIRST
(MOVD? (QUOTE GETTABLE)
(QUOTE OLDHASHGETTABLE))
(MOVD? (QUOTE MAKETABLE)
(QUOTE OLDHASHMAKETABLE))
(MOVD? (QUOTE MAPTABLE)
(QUOTE OLDHASHMAPTABLE))
(MOVD? (QUOTE TESTTABLE)
(QUOTE OLDHASHTESTTABLE))
(MOVD? (QUOTE EQMEMBTABLE)
(QUOTE OLDHASHEQMEMBTABLE))
(MOVD? (QUOTE STORETABLE)
(QUOTE OLDHASHSTORETABLE))
(MOVD? (QUOTE PUTTABLE)
(QUOTE OLDHASHPUTTABLE))
(MOVD? (QUOTE ADDTABLE)
(QUOTE OLDHASHADDTABLE))
(MOVD? (QUOTE SUBTABLE)
(QUOTE OLDHASHSUBTABLE))
)
(DEFINEQ
(HFGETTABLE
[LAMBDA (KEY TABLE) (* cdl "13-May-85 08:07")
(if (type? HFTABLE TABLE)
then [PROG [FILEV FILE (LOCALV (OLDHASHGETTABLE KEY (fetch LOCALARRAY of TABLE]
(if (OR (NULL LOCALV)
(fetch INVFLG of TABLE))
then (if (SETQ FILEV (GETHASHFILE (MSKEY TABLE KEY)
MSHASHFILE))
then (with HashTextPtr FILEV (SETFILEPTR (SETQ FILE (HASHFILENAME
MSHASHFILE))
Start))
(SETQ FILEV (READ FILE FILERDTBL)))
elseif (BOGUSVALP LOCALV)
then (SETQ LOCALV NIL))
(RETURN (if (NULL (fetch INVFLG of TABLE))
then (OR LOCALV FILEV)
else (SETQ TABLE (FORWARDTABLE TABLE))
(for X in (if (AND LOCALV FILEV)
then (UNION LOCALV FILEV)
else (OR LOCALV FILEV))
when (HFEQMEMBTABLE X KEY TABLE T) collect X]
else (OLDHASHGETTABLE KEY TABLE])
(HFMAKETABLE
[LAMBDA (N NAME INVFLG) (* cdl "12-May-85 12:47")
(if MSHASHFILE
then (create HFTABLE
LOCALARRAY ←(OLDHASHMAKETABLE N)
NAME ← NAME
INVFLG ← INVFLG
KEY ←(CONCAT [CHARACTER (COND
[(LOOKUPHASHFILE (CONCAT (if INVFLG
then "do!"
else "by!")
NAME)
NEXTHASHKEY MSHASHFILE
(if MSREADONLYFLG
then 'RETRIEVE
else '(RETRIEVE INSERT]
((NOT MSREADONLYFLG)
(* key got written by LOOKUPHASHFILE)
(NEXTHASHKEY))
(T (HELP "CAN'T SET UP READ-ONLY DATABASE FILE"]
'!))
else (OLDHASHMAKETABLE N])
(HFMAPTABLE
[LAMBDA (TABLE MFN) (* cdl "12-May-85 11:18")
(DECLARE (SPECVARS TABLE MFN))
(if (type? HFTABLE TABLE)
then [PROG (FILE TMP (HA (fetch LOCALARRAY of TABLE)))
(* The function is named MFN so as not to conflict with
the name of the fn argument in the old mapper.)
[if (fetch INVFLG of TABLE)
then [OLDHASHMAPTABLE HA (FUNCTION (LAMBDA (VAL ITEM)
(if (SETQ VAL (HFGETTABLE ITEM TABLE))
then (APPLY* MFN VAL ITEM]
else (OLDHASHMAPTABLE HA (FUNCTION (LAMBDA (VAL ITEM)
(OR (BOGUSVALP VAL)
(APPLY* MFN VAL ITEM]
(if (SETQ TMP (GETHASHFILE (MSKEY TABLE '**ALLKEYS**)
MSHASHFILE))
then (with HashTextPtr TMP (SETFILEPTR (SETQ FILE (HASHFILENAME MSHASHFILE))
Start))
(bind VAL for ITEM in (READ FILE FILERDTBL)
do (if (AND (NOT (OLDHASHTESTTABLE ITEM HA))
(SETQ VAL (HFGETTABLE ITEM TABLE)))
then (APPLY* MFN VAL ITEM]
else (* Don't worry about bogus values)
(OLDHASHMAPTABLE TABLE MFN])
(HFTESTTABLE
[LAMBDA (KEY TABLE) (* cdl "12-May-85 11:02")
(if (type? HFTABLE TABLE)
then [PROG (LOCALV FILEV FORWARD FILE)
(RETURN (if (OLDHASHTESTTABLE KEY (fetch LOCALARRAY of TABLE))
then [if (fetch INVFLG of TABLE)
then (SETQ FORWARD (FORWARDTABLE TABLE))
(for X in (OLDHASHGETTABLE KEY (fetch LOCALARRAY
of TABLE))
when (HFEQMEMBTABLE X KEY FORWARD T)
do (RETURN T) finally (GO SCN2))
else (NOT (OLDHASHEQMEMBTABLE KEY (BOGUSVAL)
(fetch LOCALARRAY of TABLE]
elseif (NOT (fetch INVFLG of TABLE))
then (LOOKUPHASHFILE (MSKEY TABLE KEY)
NIL MSHASHFILE NIL)
else (GO SCAN)))
SCAN(SETQ FORWARD (FORWARDTABLE TABLE))
SCN2(RETURN (if (SETQ FILEV (GETHASHFILE (MSKEY TABLE KEY)
MSHASHFILE))
then (with HashTextPtr FILEV (SETFILEPTR (SETQ FILE (HASHFILENAME
MSHASHFILE))
Start))
(if (for X in (READ FILE FILERDTBL)
thereis (HFEQMEMBTABLE X KEY FORWARD T))
then T]
else (OLDHASHTESTTABLE KEY TABLE])
(HFEQMEMBTABLE
[LAMBDA (KEY VALUE TABLE FLG) (* cdl "12-May-85 11:02")
(* Checks whether VALUE is a member of the TABLE entry defined by KEY. If so, value is the file position of VALUE in
the entry if the entry is on the hashfile. If the entry is in the local database, the value will be non-NIL.)
(if (type? HFTABLE TABLE)
then (if (fetch INVFLG of TABLE)
then (swap KEY VALUE)
(SETQ TABLE (FORWARDTABLE TABLE)))
(if (OLDHASHTESTTABLE KEY (fetch LOCALARRAY of TABLE))
then (OLDHASHEQMEMBTABLE KEY VALUE (fetch LOCALARRAY of TABLE))
elseif FLG
then T
elseif (SETQ KEY (GETHASHFILE (MSKEY TABLE KEY)
MSHASHFILE))
then (with HashTextPtr KEY (FILEPOS (MSVAL VALUE)
(HASHFILENAME MSHASHFILE)
Start End))
T)
else (OLDHASHEQMEMBTABLE KEY VALUE TABLE])
(HFSTORETABLE
[LAMBDA (KEY TABLST VALUE) (* cdl "12-May-85 10:55")
(if (type? HFTABLE (CADR TABLST))
then (OLDHASHPUTTABLE KEY (OR VALUE (BOGUSVAL))
(fetch LOCALARRAY of (CADR TABLST)))
(if (CDDR TABLST)
then (if (type? HFTABLE (CDDR TABLST))
then (bind (HA ←(fetch LOCALARRAY of (CDDR TABLST))) for V inside VALUE
do (OLDHASHADDTABLE V KEY HA))
else (SHOULDNT)))
else (OLDHASHSTORETABLE KEY TABLST VALUE])
(HFPUTTABLE
[LAMBDA (KEY VALUE TABLE) (* cdl "12-May-85 11:02")
(if (type? HFTABLE TABLE)
then (OLDHASHPUTTABLE KEY (OR VALUE (BOGUSVAL))
(fetch LOCALARRAY of TABLE))
else (OLDHASHPUTTABLE KEY (OR VALUE (BOGUSVAL))
TABLE])
(HFADDTABLE
[LAMBDA (KEY VALUE TABLE) (* cdl "12-May-85 11:03")
(if (type? HFTABLE TABLE)
then (SHOULDNT)
else (OLDHASHADDTABLE KEY VALUE TABLE])
(HFSUBTABLE
[LAMBDA (KEY VALUE TABLE) (* cdl "12-May-85 11:03")
(if (type? HFTABLE TABLE)
then (SHOULDNT)
else (OLDHASHSUBTABLE KEY VALUE TABLE])
)
(DEFINEQ
(LOCALFNP
[LAMBDA (FN) (* cdl " 7-May-85 14:59")
(* T if FN is KNOWN in the local database)
(if [for TABLE in '(CALL REF NOBIND)
thereis (AND (OLDHASHTESTTABLE FN (if [type? HFTABLE (SETQ TABLE (CADR (ASSOC TABLE
MSDATABASELST]
then (SETQ TABLE (fetch LOCALARRAY of TABLE))
else TABLE))
(NOT (OLDHASHEQMEMBTABLE FN (BOGUSVAL)
TABLE]
then T])
(MSKEY
[LAMBDA (TABLE KEY) (* cdl " 7-May-85 12:34")
(if (type? HFTABLE TABLE)
then (RPLSTRING MSHASHSCRATCHSTRING 1 (fetch (HFTABLE KEY) of TABLE))
(RPLSTRING MSHASHSCRATCHSTRING 3 KEY)
(SUBSTRING MSHASHSCRATCHSTRING 1 (IPLUS 2 (NCHARS KEY))
(CONSTANT (CONCAT)))
else (SHOULDNT])
(FORWARDTABLE
[LAMBDA (TABLE) (* cdl "12-May-85 11:07")
(for X in MSDATABASELST when (EQ (CAR X)
(fetch (HFTABLE NAME) of TABLE))
do (RETURN (CADR X)) finally (SELECTQ (fetch (HFTABLE NAME) of TABLE)
(HELP])
(MSVAL
[LAMBDA (VAL) (* cdl "12-May-85 11:08")
(* Produces a string with all the escapes needed for
searching with FILEPOS for PRIN2-pnames)
(RPLSTRING MSHASHSCRATCHSTRING 1 " ")
(bind C for I from 1 while (SETQ C (NTHCHAR VAL I T FILERDTBL)) do (RPLSTRING MSHASHSCRATCHSTRING
(ADD1 I)
C)
finally (RPLSTRING MSHASHSCRATCHSTRING (ADD1 I)
" ")
(RETURN (SUBSTRING MSHASHSCRATCHSTRING 1 (ADD1 I)
(CONSTANT (CONCAT])
(NEXTHASHKEY
[LAMBDA NIL (* cdl " 7-May-85 17:10")
(PROG1 NEXTHASHKEY (PUTHASHFILE 'NEXTHASHKEY (add NEXTHASHKEY 1)
MSHASHFILE])
(STOREHASHVALUE
[LAMBDA (KEY VALUE TABLE) (* cdl "13-May-85 08:11")
(PROG (PTR FILE (HASHKEY (MSKEY TABLE KEY)))
(if VALUE
then (SETFILEPTR (SETQ FILE (HASHFILENAME MSHASHFILE))
-1)
(SETQ PTR (create HashTextPtr
Start ←(GETFILEPTR FILE)))
(if (LISTP VALUE)
then (PRIN3 "( " FILE)
(for V on VALUE
do (PRIN4 (CAR V)
FILE FILERDTBL)
(PRIN3 " " FILE)
finally (if V
then (PRIN3 ". " FILE)
(PRIN4 V FILE FILERDTBL)
(PRIN3 " " FILE)))
(* Don't use SPACES to avoid line positioning)
(PRIN3 ")" FILE)
else (PRIN3 " " FILE) (* The leading space is for the EQMEMB predicate)
(PRIN4 VALUE FILE FILERDTBL)
(PRIN3 " " FILE))
(with HashTextPtr PTR (SETQ End (GETFILEPTR FILE)))
(PUTHASHFILE HASHKEY PTR MSHASHFILE)
else (PUTHASHFILE HASHKEY NIL MSHASHFILE)))
VALUE])
(GETHASHTABLE
[LAMBDA (KEY TABLE) (* cdl "12-May-85 11:08")
(PROG (FILE PTR)
(if (SETQ PTR (GETHASHFILE (MSKEY TABLE KEY)
MSHASHFILE))
then (with HashTextPtr PTR (SETFILEPTR (SETQ FILE (HASHFILENAME MSHASHFILE))
Start))
(RETURN (READ FILE FILERDTBL])
)
(RPAQ? MSHASHFILE NIL)
(RPAQ? MSREADONLYFLG NIL)
(RPAQ? NEXTHASHKEY NIL)
(RPAQ? MSFILETABLE NIL)
(RPAQ? MSHASHSCRATCHSTRING (ALLOCSTRING 255))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS MSHASHFILE MSREADONLYFLG MSFILETABLE NEXTHASHKEY MSHASHSCRATCHSTRING MSHFNS)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS MSDATABASELST MSDBEMPTY LOADDBFLG FILERDTBL)
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(TYPERECORD HFTABLE (NAME LOCALARRAY KEY INVFLG))
(TYPERECORD HashTextPtr (Start . End))
]
(DECLARE: EVAL@COMPILE
(PUTPROPS BOGUSVAL MACRO (NIL '**BOGUSVALUE**))
(PUTPROPS BOGUSVALP MACRO ((X)
(EQ X '**BOGUSVALUE**)))
)
)
(FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
HASH)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DEFINEQ
(ANALYZEFILES
[LAMBDA (FILES EVENIFVALID) (* cdl "12-May-85 11:27")
(DECLARE (GLOBALVARS FILELST))
(* Reanalyzes functions on the files inside FILES, and enters the files' dates in the masterscope file-table.
-
Each file-specification can be a list of the form (file . fns), where fns=T => all, fns=NIL => none, and otherwise
fns is a list of fns to be examined. A litatom file-specification is interpreted as (file . T). If n -
if fns=T and EVENIFVALID=NIL, attempt to load a .DATABASE file.)
(bind FILE N D FNS ALLFNS declare: (SPECVARS FILE FNS ALLFNS) for X inside FILES
collect (if (LISTP X)
then (SETQ FILE (CAR X))
(SETQ FNS (CDR X))
else (SETQ FILE X)
(SETQ FNS T))
(SETQ N (NAMEFIELD FILE))
(if (CDR (LISTP FILES))
then (printout T T .P2 FILE T))
(if (NOT (MEMB N FILELST))
then (RESETVARS ((LOADDBFLG 'NO))
(SETQ FILE (LOADFROM FILE)))
(* In case there's some spelling correction)
(SETQ N (NAMEFIELD FILE)))
(SETQ D (CAR (GETPROP N 'FILEDATES)))
(if [OR EVENIFVALID (NEQ FNS T)
(OR (NOT (GETD 'LOADDB))
(NOT (LOADDB (CDR D]
then (SETQ ALLFNS (FILEFNSLST N)) (* RESETLST so temporary state is flushed, in
particular, the file that masterscope opens.)
(RESETLST (for F in (if (EQ FNS T)
then ALLFNS
else FNS)
do (UPDATEFN F T)))
(UPDATECONTAINS N ALLFNS)
(STORETABLE N MSFILETABLE D))
(if (CDR (LISTP FILES))
then (printout T T))
(CDR D])
(BUILDDB
[LAMBDA (NAME FILES #ENTRIES) (* gbn " 5-Jun-85 22:28")
(* For creating a database and adding files to it. If NAME and FILES are both NIL, will make a new version of the
current database)
(OR NAME (AND MSHASHFILE (SETQ NAME (HASHFILENAME MSHASHFILE)))
(ERROR "No database file name"))
(if (NULL FILES)
then (SETDB NAME)
(SETQ FILES (MSFILES)))
(SETDB NAME (QUOTE CREATE)
#ENTRIES)
(SETQ FILES (for F inside FILES collect (PACKFILENAME (QUOTE VERSION)
NIL
(QUOTE BODY)
F)))
(ANALYZEFILES FILES T)
(SETDB NAME])
(COPYDB
[LAMBDA (OLDFILE NEWFILE LEAVEOPEN) (* cdl "13-May-85 10:29")
(* Copies the ms database on OLDFILE to NEWFILE,
compressing out old space)
[SETQ OLDFILE (INFILEP (if OLDFILE
then (PACKFILENAME 'BODY OLDFILE 'EXTENSION 'HASHDATABASE)
else (HASHFILENAME MSHASHFILE]
[SETQ NEWFILE (OUTFILEP (if NEWFILE
then (PACKFILENAME 'BODY NEWFILE 'EXTENSION 'HASHDATABASE)
else (PACKFILENAME 'VERSION NIL 'BODY OLDFILE]
(COPYHASHFILE OLDFILE NEWFILE (FUNCTION [LAMBDA (KEY VALUE OLDFILE NEWFILE)
(* Old and new HASH incompatibility!)
(if (NUMBERP KEY)
then KEY
elseif (type? HashTextPtr KEY)
then (* old HASH)
(SETFILEPTR (SETQ NEWFILE (HASHFILENAME OLDFILE))
-1)
(SETQ OLDFILE (HASHFILENAME VALUE))
(with HashTextPtr KEY (SETQ VALUE (GETFILEPTR NEWFILE))
(COPYBYTES OLDFILE NEWFILE Start End)
(SETQ Start VALUE)
(SETQ End (GETFILEPTR NEWFILE)))
KEY
else VALUE])
NIL LEAVEOPEN])
(FLUSHDB
[LAMBDA NIL (* cdl "12-May-85 11:09")
(if (AND MSHASHFILE (NOT MSREADONLYFLG))
then (for X in MSDATABASELST bind LA KEYS REMKEYS TABLE FILEV FILE
declare: (SPECVARS LA KEYS REMKEYS TABLE)
do (if (type? HFTABLE (SETQ TABLE (CDDR X)))
then (SETQ KEYS NIL)
(SETQ REMKEYS NIL)
[OLDHASHMAPTABLE (SETQ LA (fetch LOCALARRAY of TABLE))
(FUNCTION (LAMBDA (VAL ITEM)
(if (STOREHASHVALUE ITEM (HFGETTABLE ITEM TABLE)
TABLE)
then (push KEYS ITEM)
else (push REMKEYS ITEM))
(OLDHASHPUTTABLE ITEM NIL LA]
(if (OR KEYS REMKEYS)
then (STOREHASHVALUE '**ALLKEYS**(UNION KEYS (LDIFFERENCE
(GETHASHTABLE '**ALLKEYS**
TABLE)
REMKEYS))
TABLE)))
(if (type? HFTABLE (SETQ TABLE (CADR X)))
then (SETQ KEYS NIL)
(SETQ REMKEYS NIL)
[OLDHASHMAPTABLE (SETQ LA (fetch LOCALARRAY of TABLE))
(FUNCTION (LAMBDA (VAL ITEM)
(if (BOGUSVALP VAL)
then (SETQ VAL NIL))
(if VAL
then (push KEYS ITEM)
else (push REMKEYS ITEM))
(if (NOT (EQLST VAL (GETHASHTABLE ITEM TABLE)))
then (STOREHASHVALUE ITEM VAL TABLE))
(OLDHASHPUTTABLE ITEM NIL LA]
(if (OR KEYS REMKEYS)
then (SETQ KEYS (UNION (if (SETQ FILEV (GETHASHFILE (MSKEY TABLE
'**ALLKEYS**)
MSHASHFILE))
then (with HashTextPtr FILEV
(SETFILEPTR (SETQ FILE
(HASHFILENAME
MSHASHFILE))
Start))
(LDIFFERENCE (SETQ FILEV
(READ FILE FILERDTBL))
REMKEYS))
KEYS))
(if (EQLST FILEV KEYS)
then (STOREHASHVALUE '**ALLKEYS** KEYS TABLE])
(EQLST
[LAMBDA (L1 L2) (* cdl " 7-May-85 15:06")
(if (AND (for X in L1 always (FMEMB X L2))
(for X in L2 always (FMEMB X L1)))
then T])
(HFGETARGS
[LAMBDA (NAME DEF DATA) (* cdl "12-May-85 11:24")
(* An analyze userfn that collects the argument list
for the ARG table)
(DECLARE (GLOBALVARS MSHASHFILE)
(SPECVARS DEF DATA))
[if MSHASHFILE
then (* NLSETQ cause ARGLIST could cause an error)
(NLSETQ (RPLACD (FASSOC 'ARG DATA)
(OR (ARGLIST DEF)
T]
DATA])
(MSFILECHECK
[LAMBDA (FILES) (* cdl " 7-May-85 14:45")
(DECLARE (GLOBALVARS FILELST))
(* Returns alist containing the fullnames of files inside FILES which were known to the database and no longer exist
(keyed under DELETED) or whose latest version is not known to the database (keyed under CHANGED). If FILES=T, checks
the files known to the database. If FILES=NIL, uses filelst)
[if (EQ FILES T)
then (SETQ FILES (MSFILES))
elseif FILES
then FILES
else (SETQ FILES (SORT (for FILE in FILELST collect (CDAR (GETPROP FILE 'FILEDATES]
(bind NF CHANGED DELETED for FL inside FILES
do (if (SETQ NF (INFILEP (PACKFILENAME 'VERSION NIL 'BODY FL)))
then (if [NEQ NF (CDR (GETTABLE (NAMEFIELD FL)
(CADR MSFILETABLE]
then (push CHANGED NF))
elseif [SETQ FL (CDR (GETTABLE (NAMEFIELD FL)
(CADR MSFILETABLE]
then (push DELETED FL)) (* The file disappeared if NF=NIL--return the
previously known name)
finally (RETURN (NCONC [if DELETED
then (LIST (CONS 'DELETED (DREVERSE DELETED]
(if CHANGED
then (LIST (CONS 'CHANGED (DREVERSE CHANGED])
(MSFILES
[LAMBDA NIL (* cdl " 7-May-85 15:07")
(* Returns a list of the files known to the current ms
database.)
(PROG (VAL)
(DECLARE (SPECVARS VAL))
[MAPTABLE (CADR MSFILETABLE)
(FUNCTION (LAMBDA (DATE FILE)
(push VAL (CDR DATE]
(RETURN (SORT VAL])
(RESTOREDB
[LAMBDA (FILE WRITEDATE OLDFILES) (* cdl "13-May-85 08:23")
(* Re-opens a (new version of a) previously opened database file. Used as a status function for the mshashfile.
OLDFILES is a list of fullnames of files that were on FILELST and known to the database when the sysout was made.)
(* AFTERCLOSE FILE)
(if [NULL (SETQ FILE (INFILEP (PACKFILENAME 'VERSION NIL 'BODY FILE]
then (SETDB)
NIL
else (SETQ FILE (SETDB FILE 'RESTORE))
[if (NOT (IEQP WRITEDATE (GETFILEINFO FILE 'IWRITEDATE)))
then (bind FLG NEWF for OLDF in OLDFILES unless (EQ [SETQ NEWF
(CDR (GETTABLE (CAR OLDF)
(CADR MSFILETABLE]
(CDR OLDF))
do (* If NEWF=NIL, the file was removed from the database.
Perhaps we should mark all its in-core functions as
needing reanalysis)
(if (NULL FLG)
then (printout T T
"***WARNING: The database has been updated. Information about files
that you currently have loaded has changed:"
T)
(SETQ FLG T))
(if (CDR OLDF)
then (printout T T .P2 (CDR OLDF)
" has been ")
(if NEWF
then (printout T "replaced by " .P2 NEWF)
else (printout T "deleted"))
else (printout T T .P2 NEWF " has been added"))
finally (if FLG
then (printout T T T
"You might want to LOADFROM or REANALYZE those files."
T]
T])
(SETDB
[LAMBDA (FILE MODE #ENTRIES) (* gbn " 5-Jun-85 22:29")
(* * Sets FILE to be the current masterscope hashfile, open for write if MODE is T or BOTH, new file if MODE=CREATE,
restores old database if MODE=RESTORE. If FILE is NIL, closes any such file which is currently open.
If FILE is T, simply changes the write-mode of the current file)
(DECLARE (GLOBALVARS FILELST)) (* MSDBEMPTY is a masterscope variable)
(PROG [CLOSEDFILE (RESTOREFLG (EQ MODE (QUOTE RESTORE]
(if (AND MSHASHFILE (HASHFILEP MSHASHFILE))
then (if (NEQ MODE (QUOTE NOFLUSH))
then (FLUSHDB))
(SETQ CLOSEDFILE (CLOSEHASHFILE MSHASHFILE)))
[if (EQ FILE T)
then (* Reopen the old file with a new access mode)
(if CLOSEDFILE
then (SETQ MSHASHFILE (OPENHASHFILE CLOSEDFILE MODE)))
elseif FILE
then (SETQ FILE (PACKFILENAME (QUOTE BODY)
FILE
(QUOTE EXTENSION)
(QUOTE HASHDATABASE)))
(if RESTOREFLG
then (* Don't want to wipe out old local database;
use previous read mode.)
(SETQ MODE (NOT MSREADONLYFLG))
else (%. ERASE))
(SETQ MSHASHFILE (if (EQ MODE (QUOTE CREATE))
then (SETQ MODE T)
(SETQ MSDBEMPTY T)
(CREATEHASHFILE FILE (QUOTE EXPR)
NIL #ENTRIES)
else (OPENHASHFILE FILE MODE)))
(SETQ NEXTHASHKEY (OR (GETHASHFILE (QUOTE NEXTHASHKEY)
MSHASHFILE)
(CONSTANT (CHARCODE A]
(if MSHASHFILE
then [if (NULL CLOSEDFILE)
then (* Set up the hashfile functions the first time a
database is open. That way non-users don't pay.)
(for X in MSHFNS do (MOVD (CAR X)
(CADR X]
(MSHASHWHENCLOSE MSHASHFILE)
(SETQ MSREADONLYFLG (SELECTQ MODE
((INPUT NIL)
T)
NIL))
(if (AND (NEQ FILE T)
(NOT RESTOREFLG))
then (if (NULL MSDATABASELST)
then (%. WHO CALLS FUM)) (* Gets the database initialized, even though MSINIT
isn't an entry.)
)
(RETURN (HASHFILENAME MSHASHFILE))
elseif CLOSEDFILE
then (%. ERASE)
(* If we're closing up, need to make masterscope think the database went away, or it will still try to do lookups on
random occasions, such as a record redeclaration)
(RETURN CLOSEDFILE])
(UPDATECONTAINS
[LAMBDA (FILE NEWFNS KEEPFLG) (* cdl " 7-May-85 15:14")
(* Makes sure that the database is aware of which functions have disappeared, and who contains what.
FILE is just the namefield. KEEPFLG is T then called from DUMPDB. We then are more cautious about destroying
information about this function, cause it might have been moved to another file.)
(PROG (UPDATEFNS OLDFNS (TBL (ASSOC 'CONTAINS MSDATABASELST)))
(DECLARE (SPECVARS UPDATEFNS))
(SETQ OLDFNS (GETTABLE FILE (CADR TBL)))
(if (AND (NOT KEEPFLG)
(SETQ UPDATEFNS (LDIFFERENCE OLDFNS NEWFNS)))
then (%. ERASE IN UPDATEFNS))
[for FN in OLDFNS unless (FMEMB FN NEWFNS)
do (* Keep a single file, not a list, cause the analyzed
definition is from only one file.)
(for CONTAINER inside (GETTABLE FN (CDDR TBL))
do (STORETABLE CONTAINER TBL (REMOVE FN (GETTABLE CONTAINER (CADR TBL]
(STORETABLE FILE TBL NEWFNS])
(UPDATEDB
[LAMBDA (ADDFILES DELETEFILES ADDONLY NOGCFLG) (* cdl "12-May-85 13:02")
(DECLARE (SPECVARS ADDFILES DELETEFILES ADDONLY NOGCFLG)
(GLOBALVARS DWIMWAIT))
(* Copies the current masterscope hash-file into a scratch file, then information about files inside DELETEFILES
(and erases function information for functions only on those files), then loads the .DATABASE files for the files in
ADDFILES. The copy is so that this function will execute even though someone else is reading the current database.
The database is copied to a scratch file, then renamed to be a newer version of the previous database, which is
deleted. This allows others to use the old database while the copying is going on. If an earlier version of the
scratch file exists, it means that someone else is currently updating (there version disappears when the complete
successfully or logout), so we wait for them to finish.)
(* Doesn't look for out-of-date files if ADDONLY. -
If ADDFILES is a FIXP, it is the maximum number of files to be analyzed, as a precaution against running out of
space when updating large databases. Repeated calls on UPDATEDB with a low ADDFILES should get through.
-
If NOGCFLG, the database is copied without compacting, which is considerably faster, though the resulting file is
much larger. It may be fastest to do a number of updates with a small ADDFILES and NOGCFLG, then do a final one with
compacting.)
(if (NULL MSHASHFILE)
then (ERROR "No current hash-database file"))
(RESETLST (PROG (SCRATCH CHECKEDFILES DBFILES NFILES NADDFILES (NHF (LIST NIL))
(OLDMSN (HASHFILENAME MSHASHFILE)))
[RESETSAVE (PROGN NHF)
'(PROGN (CLOSEF? (CAR OLDVALUE))
(AND RESETSTATE (DELFILE (CAR OLDVALUE]
[SETQ NHF (CAR (RPLACA NHF (CLOSEF (OPENFILE (SETQ SCRATCH
(PACKFILENAME 'DIRECTORY
(FILENAMEFIELD
OLDMSN 'DIRECTORY)
'NAME
'NEWHASHDATABASE
'EXTENSION 'SCRATCH
'TEMPORARY 'S))
'OUTPUT 'NEW]
(* The CONS cell holds the name for resetsaves, but we
don't need it below)
(* PACKFILENAME produces version -1 for ;S on TOPS20)
(if (EQ (SYSTEMTYPE)
'TOPS20)
then (SETQ SCRATCH (PACKFILENAME 'VERSION NIL 'BODY SCRATCH)))
[bind OLDV (RPT ← 1) until (EQ NHF (SETQ OLDV (FULLNAME SCRATCH 'OLDEST)))
do (DISMISS 2000)
(if RPT
then (if (EQ RPT 5)
then (printout T T (GETFILEINFO OLDV 'AUTHOR)
" seems to be updating the database right now."
T "I'm waiting for him to finish." T T)
(SETQ RPT NIL)
else (add RPT 1]
(* If there is a version earlier than the one we got, someone else must have it, and we must wait until he gets rid
of it (by deleting it))
(if (NULL ADDONLY)
then (* Do this first, so user can break MSFILECHECK to
modify things without having to wait for the copy to
complete.)
(SETQ CHECKEDFILES (MSFILECHECK T)))
[RESETSAVE (SETDB)
'(PROGN (SETDB (PACKFILENAME 'VERSION NIL 'BODY OLDVALUE]
(* Leave this sysout with the latest version of the
current database open--hopefully, the new one.)
(if (FIXP ADDFILES)
then (SETQ NFILES ADDFILES) (* Limit on number of files to analyze is coded in
ADDFILES; necessary as an antidote to storage-full)
(SETQ ADDFILES NIL))
(SETQ ADDFILES (NCONC (CDR (FASSOC 'CHANGED CHECKEDFILES))
(MKLIST ADDFILES)))
(SETQ ADDFILES (for F in ADDFILES unless (bind (NAMEF ←(NAMEFIELD F))
for DF in DELETEFILES
thereis (EQ NAMEF (NAMEFIELD DF)))
collect F))
(SETQ NADDFILES (LENGTH ADDFILES))
(if (IGREATERP NADDFILES 0)
then (printout T T NADDFILES " files to be updated:" 5 .PARA2 5 0 ADDFILES))
(if NOGCFLG
then (COPYFILE OLDMSN NHF) (* File comes back closed, so re-open it to be
consistent with the LEAVEOPEN logic.)
(OPENHASHFILE NHF 'BOTH)
else (COPYDB OLDMSN NHF T)) (* Must leave the new file open--otherwise, the user
might lose access to it before he has started to load
in the .DATABASE files)
(SETDB NHF T)
(for F inside DELETEFILES
do (SETQ F (NAMEFIELD F))
(UPDATECONTAINS F)
(STORETABLE F MSFILETABLE NIL))
(for F NAMEF in (CDR (FASSOC 'DELETED CHECKEDFILES)) eachtime (SETQ NAMEF
(NAMEFIELD F))
when [AND (for DF inside DELETEFILES never (EQ NAMEF (NAMEFIELD DF)))
(EQ 'Y (ASKUSER DWIMWAIT 'Y (LIST (PACKFILENAME 'VERSION NIL 'BODY F)
"no longer exists. Shall I remove it from the database"]
do (UPDATECONTAINS NAMEF)
(STORETABLE NAMEF MSFILETABLE NIL))
(for F DBF in ADDFILES as I to (OR NFILES NADDFILES)
do (printout T T T .P2 F T)
(if (SETQ DBF (LOADDB (FINDFILE F)))
then (push DBFILES DBF)
else (ANALYZEFILES F T)))
(SETDB)
(* This closes the file, but other updaters are still locked out cause they go for a new version and then trip over
our old one.)
[COND
((SETQ NHF (RENAMEFILE NHF (PACKFILENAME 'VERSION NIL 'BODY OLDMSN)))
(bind F (OLDV ←(FILENAMEFIELD OLDMSN 'VERSION))
(STEM ←(PACKFILENAME 'VERSION NIL 'BODY OLDMSN))
while (AND (SETQ F (FULLNAME STEM 'OLDEST))
(IGEQ OLDV (FILENAMEFIELD F 'VERSION))
(DELFILE F)))
(* Success: We delete the old hash file and all the .DATABASE files we loaded, plus any earlier versions.
DELFILE will return NIL if we don't have deletion rights.)
(for DBF in DBFILES
do (* Don't delete dbfiles newer than the one we just
read)
(bind F (OLDV ←(FILENAMEFIELD DBF 'VERSION))
(STEM ←(PACKFILENAME 'VERSION NIL 'BODY DBF))
while (AND (SETQ F (FULLNAME STEM 'OLDEST))
(IGEQ OLDV (FILENAMEFIELD F 'VERSION))
(DELFILE F] (* Now others can get in to read or update.)
(if (AND NFILES (IGREATERP NADDFILES NFILES))
then (printout T T (IDIFFERENCE NADDFILES NFILES)
" files still to be updated." T))
(RETURN NHF])
(MSHASHWHENCLOSE
[LAMBDA (HASHFILE) (* cdl " 7-May-85 17:18")
(DECLARE (GLOBALVARS FILELST))
(WHENCLOSE (HASHFILENAME HASHFILE)
'STATUS
[FUNCTION (LAMBDA (FILE)
(LIST 'RESTOREDB FILE (GETFILEINFO FILE 'IWRITEDATE)
(for F in FILELST
collect (* The CDR is NIL for files not in the database)
(CONS F (CDR (HFGETTABLE F (CADR MSFILETABLE]
'CLOSEALL 'NO 'EOF (FUNCTION NILL)
'AFTER
(FUNCTION (LAMBDA (F) (* after the hashfile is closed, reset the global name
and file)
(SETQ MSHASHFILE NIL])
)
(* (ADDVARS (ANALYZEUSERFNS HFGETARGS)))
(PUTPROPS MSHASH COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2721 9953 (HFGETTABLE 2731 . 3857) (HFMAKETABLE 3859 . 4697) (HFMAPTABLE 4699 . 6131) (
HFTESTTABLE 6133 . 7535) (HFEQMEMBTABLE 7537 . 8562) (HFSTORETABLE 8564 . 9167) (HFPUTTABLE 9169 .
9501) (HFADDTABLE 9503 . 9726) (HFSUBTABLE 9728 . 9951)) (9954 13800 (LOCALFNP 9964 . 10555) (MSKEY
10557 . 10968) (FORWARDTABLE 10970 . 11320) (MSVAL 11322 . 12000) (NEXTHASHKEY 12002 . 12211) (
STOREHASHVALUE 12213 . 13403) (GETHASHTABLE 13405 . 13798)) (14589 37713 (ANALYZEFILES 14599 . 16555)
(BUILDDB 16557 . 17290) (COPYDB 17292 . 18663) (FLUSHDB 18665 . 20835) (EQLST 20837 . 21080) (
HFGETARGS 21082 . 21654) (MSFILECHECK 21656 . 23144) (MSFILES 23146 . 23621) (RESTOREDB 23623 . 25409)
(SETDB 25411 . 28331) (UPDATECONTAINS 28333 . 29545) (UPDATEDB 29547 . 36954) (MSHASHWHENCLOSE 36956
. 37711)))))
STOP