(FILECREATED " 4-May-84 10:11:42" {PHYLUM}<LISPCORE>LIBRARY>DATABASEFNS.;3 12890
changes to: (FNS LOADDB)
previous date: "15-Mar-84 11:23:54" {PHYLUM}<LISPCORE>LIBRARY>DATABASEFNS.;2)
(PRETTYCOMPRINT DATABASEFNSCOMS)
(RPAQQ DATABASEFNSCOMS [(* Does automatic Masterscope database maintenance)
[DECLARE: FIRST (P (VIRGINFN (QUOTE LOAD)
T)
(MOVD? (QUOTE LOAD)
(QUOTE OLDLOAD))
(VIRGINFN (QUOTE LOADFROM)
T)
(MOVD? (QUOTE LOADFROM)
(QUOTE OLDLOADFROM))
(VIRGINFN (QUOTE MAKEFILE)
T)
(MOVD? (QUOTE MAKEFILE)
(QUOTE OLDMAKEFILE]
(FNS DBFILE DBFILE1 DBFILE2 LOAD LOADFROM MAKEFILE)
(ADDVARS (LINKEDFNS OLDLOAD))
(P (RELINK (QUOTE MAKEFILES)))
(FNS DUMPDB LOADDB MAKEDB)
(PROP PROPTYPE DATABASE)
(INITVARS (LOADDBFLG (QUOTE ASK))
(SAVEDBFLG (QUOTE ASK)))
(ADDVARS (MAKEFILEFORMS (MAKEDB FILE)))
(* To permit MSHASH interface)
(INITVARS (MSHASHFILENAME)
(MSFILETABLE))
(LOCALVARS . T)
(BLOCKS (LOADDB LOADDB DBFILE DBFILE1 DBFILE2 (NOLINKFNS . T)))
(DECLARE: EVAL@COMPILE DONTCOPY (P (RESETSAVE DWIMIFYCOMPFLG T])
(* Does automatic Masterscope database maintenance)
(DECLARE: FIRST
(VIRGINFN (QUOTE LOAD)
T)
(MOVD? (QUOTE LOAD)
(QUOTE OLDLOAD))
(VIRGINFN (QUOTE LOADFROM)
T)
(MOVD? (QUOTE LOADFROM)
(QUOTE OLDLOADFROM))
(VIRGINFN (QUOTE MAKEFILE)
T)
(MOVD? (QUOTE MAKEFILE)
(QUOTE OLDMAKEFILE))
)
(DEFINEQ
(DBFILE
[LAMBDA (FILE ASKFLAG) (* lmm "29-APR-81 20:27")
(* Finds a database file that corresponds to the contents of FILE. Looks in directory of FILE, and also in the
directory that file originally came from, if it was copied. Returns NIL if no database file is found, else
(fulldbfilename . filedates), where filedates identifies the name under which the file that the database corresponds
to is currently known. -
If FILE doesn't have a version, tries to get database for version in core, or most recent version if it hasn't been
loaded)
(DECLARE (GLOBALVARS COMPILE.EXT FILERDTBL))
[COND
((NULL FILE)
(SETQ FILE (INPUT)))
((EQ (FILENAMEFIELD FILE (QUOTE EXTENSION))
COMPILE.EXT) (* Map compiled file into symbolic name)
(SETQ FILE (PACKFILENAME (QUOTE EXTENSION)
NIL
(QUOTE VERSION)
NIL
(QUOTE BODY)
FILE]
(PROG [(FILEDATES (COND
[(AND (NULL (FILENAMEFIELD FILE (QUOTE VERSION)))
(CAR (GETPROP (NAMEFIELD FILE)
(QUOTE FILEDATES]
([SETQ FILE (COND
(ASKFLAG (INFILEP FILE))
(T (FINDFILE FILE]
(CONS (FILEDATE FILE)
FILE]
(AND FILEDATES (RETURN (DBFILE1 FILE FILEDATES])
(DBFILE1
[LAMBDA (F FILEDATES) (* rmk: " 9-NOV-83 02:50")
(* Searches databases based on F to find one that matches FILEDATES. Returns (dbfilename . filedates) if successful.
For efficiency, checks the most likely highest version first, before doing the directory enumeration)
(PROG [(HIGHEST (INFILEP (PACKFILENAME (QUOTE EXTENSION)
(QUOTE DATABASE)
(QUOTE VERSION)
(QUOTE NIL)
(QUOTE BODY)
F]
(RETURN (COND
((NULL HIGHEST)
NIL)
((DBFILE2 HIGHEST FILEDATES)
(CONS HIGHEST FILEDATES))
(T (for DBF in (REMOVE HIGHEST (FILDIR (PACKFILENAME (QUOTE EXTENSION)
(QUOTE DATABASE)
(QUOTE VERSION)
(QUOTE *)
(QUOTE BODY)
F)))
when (DBFILE2 DBF FILEDATES) do (RETURN (CONS DBF FILEDATES])
(DBFILE2
[LAMBDA (DBF FILEDATES) (* rmk: " 9-NOV-83 02:48")
(* T if DBF is the name of the database file matching
FILEDATES)
(DECLARE (GLOBALVARS FILERDTBL))
[RESETSAVE (SETQ DBF (OPENFILE DBF (QUOTE INPUT)))
(QUOTE (PROGN (CLOSEF? OLDVALUE] (* The close is done in the LOADDB RESETLST, except when
a candidate file isn't correct)
(SKREAD DBF) (* Skip LOAD error message)
(COND
[(STREQUAL (CAR FILEDATES)
(CAR (READ DBF FILERDTBL]
(T (CLOSEF DBF)
NIL])
(LOAD
[LAMBDA (FILE LDFLG PRINTFLG) (* lmm "29-APR-81 20:27")
(SETQ FILE (OLDLOAD FILE LDFLG PRINTFLG))
(COND
((NEQ LDFLG (QUOTE SYSLOAD))
(LOADDB FILE T)))
FILE])
(LOADFROM
[LAMBDA (FILE FNS LDFLG) (* lmm "29-APR-81 20:27")
(SETQ FILE (OLDLOADFROM FILE FNS LDFLG))
(LOADDB FILE T)
FILE])
(MAKEFILE
[LAMBDA (FILE OPTIONS REPRINTFNS SOURCEFILE)
(* lmm "29-APR-81 20:27")
(SETQ FILE (OLDMAKEFILE FILE OPTIONS REPRINTFNS SOURCEFILE))
(DUMPDB FILE T)
FILE])
)
(ADDTOVAR LINKEDFNS OLDLOAD)
(RELINK (QUOTE MAKEFILES))
(DEFINEQ
(DUMPDB
[LAMBDA (FILE PROPFLG) (* jds "21-Feb-84 10:29")
(* Dumps a Masterscope database for functions in FILE. Checks the DATABASE property if PROPFLG=T which is how the
MAKEFILE advice calls it. A user-level call would default PROPFLG to NIL.)
(* The FILE check is because MAKEFILE returns a list
when it doesn't understand the options)
(DECLARE (GLOBALVARS MSHASHFILENAME MSFILETABLE SAVEDBFLG))
(AND FILE (LITATOM FILE)
(PROG (DBFILE (FL (NAMEFIELD FILE))
FNS
(FFNS (FILEFNSLST FILE)))
(COND
(FFNS)
((AND MSFILETABLE (TESTTABLE FL (CADR MSFILETABLE)))
(* Always dump if this is a known file)
(SETQ PROPFLG NIL))
(T (COND
(PROPFLG (/REMPROP FL (QUOTE DATABASE)))
(T (printout T T FILE " has no functions." T)))
(RETURN)))
(SETQ FNS FFNS)
(COND
([OR (NULL PROPFLG)
(EQ (GETPROP FL (QUOTE DATABASE))
(QUOTE YES))
(EQ SAVEDBFLG (QUOTE YES))
(AND MSFILETABLE (TESTTABLE FL (CADR MSFILETABLE]
(* If MSHASH is loaded, only dump functions in the local
database)
[COND
(MSHASHFILENAME (SETQ FNS (for FN in FNS when (PROGN (UPDATEFN FN)
(LOCALFNP FN))
collect FN]
[RESETLST [RESETSAVE (SETQ DBFILE (OPENFILE (PACKFILENAME (QUOTE EXTENSION)
(QUOTE DATABASE)
(QUOTE VERSION)
NIL
(QUOTE BODY)
FILE)
(QUOTE OUTPUT)
(QUOTE NEW)))
(QUOTE (PROGN (CLOSEF? OLDVALUE)
(AND RESETSTATE (DELFILE OLDVALUE]
(RESETSAVE (OUTPUT DBFILE))
(PRIN1
"(PROGN (PRIN1 %"Use LOADDB to load database files!
%" T) (ERROR!))
")
[AND MSFILETABLE (STORETABLE FL MSFILETABLE
(PRINT (CAR (GETPROP FL (QUOTE FILEDATES]
(COND
(MSHASHFILENAME (UPDATECONTAINS FL FFNS T)))
(* T flag means that the function won't be erased--it
might still be interesting)
(printout NIL "FNS " .P2 FFNS T)
(* So the database file knows which functions are on the
file)
(COND
(FNS (DUMPDATABASE FNS))
(T (printout NIL "STOP" T]
[COND
(PROPFLG (PRINT DBFILE T))
(T (/PUT FL (QUOTE DATABASEFILENAME)
DBFILE) (* Remember that we have this file valid already.)
(/PUT FL (QUOTE DATABASE)
(QUOTE YES] (* Take future note of the databae on a user call)
(RETURN DBFILE])
(LOADDB
[LAMBDA (FILE ASKFLAG) (* jds " 4-May-84 09:44")
(* Loads the database file corresponding to FILE, asking for confirmation only if ASKFLAG is T, which is the case
from the advice on LOAD but not from usual user-level calls. Before asking, it looks around first to see whether a
database file of the appropriate name really exists.)
(DECLARE (GLOBALVARS MSHASHFILENAME MSFILETABLE MSARGTABLE DWIMWAIT FILERDTBL LOADDBFLG))
(RESETLST (PROG (TEM NEWFNS FORFILE (NF (NAMEFIELD FILE))
(DBFILE (DBFILE FILE ASKFLAG)))
(COND
(DBFILE (SETQ FORFILE (CDR DBFILE))
(SETQ DBFILE (CAR DBFILE)))
(T (COND
((NULL ASKFLAG)
(printout T "no database file found for " NF T)))
(RETURN)))
(COND
([COND
[ASKFLAG (COND
((EQ (GETPROP NF (QUOTE DATABASEFILENAME))
DBFILE) (* If the database for this very file has already been
loaded, don't bother doing it again.)
(printout T "Database " DBFILE " already loaded." T)
NIL)
(T (SELECTQ (GETPROP NF (QUOTE DATABASE))
(YES T)
(NO NIL)
(SELECTQ LOADDBFLG
(YES (/PUT NF (QUOTE DATABASE)
(QUOTE YES)))
(NO (/PUT NF (QUOTE DATABASE)
(QUOTE NONE))
NIL)
(OR (AND MSFILETABLE (TESTTABLE
NF
(CADR MSFILETABLE)))
(COND
((EQ (ASKUSER DWIMWAIT (QUOTE Y)
(LIST
"load database for"
NF))
(QUOTE Y))
(/PUT NF (QUOTE DATABASE)
(QUOTE YES)))
(T (/PUT NF (QUOTE DATABASE)
(QUOTE NO))
NIL]
(T (/PUT NF (QUOTE DATABASE)
(QUOTE YES]
(LISPXPRINT DBFILE T) (* DBFILE was opened in DBFILE)
(RESETSAVE (INPUT DBFILE))
[COND
((EQ (SETQ TEM (READ NIL FILERDTBL))
(QUOTE FNS))
(SETQ NEWFNS (READ NIL FILERDTBL))
(COND
((EQ (SETQ TEM (READ NIL FILERDTBL))
(QUOTE ARGS))
[COND
[MSHASHFILENAME (bind F while (SETQ F (READ NIL FILERDTBL))
do (STORETABLE F MSARGTABLE (READ NIL FILERDTBL]
(T (while (READ NIL FILERDTBL]
(SETQ TEM (READ NIL FILERDTBL]
(COND
((OR (EQ (CAR (LISTP TEM))
(QUOTE READATABASE))
(EQ TEM (QUOTE STOP)))
(COND
((NEQ TEM (QUOTE STOP)) (* It must be (READATABASE))
(READATABASE)))
(COND
(MSHASHFILENAME (UPDATECONTAINS NF NEWFNS)))
(AND MSFILETABLE (STORETABLE NF MSFILETABLE FORFILE))
(* This is done whether or not there is a hashfile.)
(UPDATEFILES) (* Mark any edited fns as needing to be reanalyzed.)
(for FN in (CDR (GETP NF (QUOTE FILE)))
when (OR (EXPRP FN)
(GETP FN (QUOTE EXPR)))
do (MSMARKCHANGED FN)))
(T (printout T T DBFILE " is not a database file!" T)
(* So that value of LOADDB is NIL)
(SETQ DBFILE NIL)))
(/PUT NF (QUOTE DATABASEFILENAME)
DBFILE) (* Remember the name of the database we just loaded.)
(RETURN DBFILE])
(MAKEDB
[LAMBDA (F) (* DECLARATIONS: UNDOABLE)
(* rmk: " 9-NOV-83 02:56")
(DECLARE (GLOBALVARS SAVEDBFLG MSFILETABLE DWIMWAIT))
(SETQ F (NAMEFIELD F))
(* The extension is stripped off for purposes of the DATABASE. This maps compiled files into the root name, but
means that we can't have multiple-extension files with different database status)
(COND
((INFILECOMS? T (QUOTE FNS)
(FILECOMS F))
(OR (FMEMB (GETPROP F (QUOTE DATABASE))
(QUOTE (YES NO)))
(FMEMB SAVEDBFLG (QUOTE (YES NO)))
(AND MSFILETABLE (TESTTABLE F (CADR MSFILETABLE)))
(/PUT F (QUOTE DATABASE)
(COND
((EQ (QUOTE Y)
(ASKUSER DWIMWAIT (QUOTE N)
"Do you want a Masterscope Database for this file? "))
(QUOTE YES))
(T (QUOTE NO])
)
(PUTPROPS DATABASE PROPTYPE IGNORE)
(RPAQ? LOADDBFLG (QUOTE ASK))
(RPAQ? SAVEDBFLG (QUOTE ASK))
(ADDTOVAR MAKEFILEFORMS (MAKEDB FILE))
(* To permit MSHASH interface)
(RPAQ? MSHASHFILENAME )
(RPAQ? MSFILETABLE )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: LOADDB LOADDB DBFILE DBFILE1 DBFILE2 (NOLINKFNS . T))
]
(DECLARE: EVAL@COMPILE DONTCOPY
(RESETSAVE DWIMIFYCOMPFLG T)
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (1506 5001 (DBFILE 1516 . 2799) (DBFILE1 2801 . 3716) (DBFILE2 3718 . 4417) (LOAD 4419
. 4616) (LOADFROM 4618 . 4774) (MAKEFILE 4776 . 4999)) (5063 12390 (DUMPDB 5073 . 8031) (LOADDB 8033
. 11465) (MAKEDB 11467 . 12388)))))
STOP