(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10) (FILECREATED "12-May-2026 12:45:18" {MEDLEY}DATABASEFNS.;13 19361 :EDIT-BY rmk :CHANGES-TO (FNS DUMPDB MAKEDB) :PREVIOUS-DATE "11-May-2026 14:41:08" {MEDLEY}DATABASEFNS.;11) (PRETTYCOMPRINT DATABASEFNSCOMS) (RPAQQ DATABASEFNSCOMS [ (* ;; "Does automatic Masterscope database maintenance") [DECLARE%: FIRST (P (VIRGINFN 'LOAD T) (MOVD? 'LOAD 'OLDLOAD) (VIRGINFN 'LOADFROM T) (MOVD? 'LOADFROM 'OLDLOADFROM) (VIRGINFN 'MAKEFILE T) (MOVD? 'MAKEFILE 'OLDMAKEFILE] (FNS DBFILE DBFILE1 DBFILE2 LOAD LOADFROM MAKEFILE) (ADDVARS (LINKEDFNS OLDLOAD)) (P (RELINK 'MAKEFILES)) (FNS DUMPDB LOADDB MAKEDB) (PROP PROPTYPE DATABASE) (INITVARS (LOADDBFLG 'ASK) (SAVEDBFLG 'ASK)) (ADDVARS (MAKEFILEFORMS (MAKEDB FILE))) (INITVARS (MSFILETABLE) (DEFAULTDATABASECOPYRIGHTOWNER 'NEVER)) (* ; "To permit MSHASH interface") (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 'LOAD T) (MOVD? 'LOAD 'OLDLOAD) (VIRGINFN 'LOADFROM T) (MOVD? 'LOADFROM 'OLDLOADFROM) (VIRGINFN 'MAKEFILE T) (MOVD? 'MAKEFILE 'OLDMAKEFILE) ) (DEFINEQ (DBFILE [LAMBDA (FILE ASKFLAG) (* ; "Edited 11-May-2026 14:35 by mth") (* ; "Edited 24-Oct-2021 16:50 by rmk:") (* 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))) ((MEMB (U-CASE (FILENAMEFIELD FILE 'EXTENSION)) *COMPILED-EXTENSIONS*) (* ;  "Map compiled file into symbolic name") (SETQ FILE (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY FILE] (LET [(FILEDATES (COND [(AND (NULL (FILENAMEFIELD FILE 'VERSION)) (CAR (GETPROP (ROOTFILENAME FILE) 'FILEDATES] ([SETQ FILE (COND (ASKFLAG (INFILEP FILE)) (T (FINDFILE FILE] (CONS (FILEDATE FILE) FILE] (AND FILEDATES (DBFILE1 FILE FILEDATES]) (DBFILE1 [LAMBDA (F FILEDATES) (* ; "Edited 24-Oct-2021 15:43 by rmk:") (* jds "25-Sep-86 20:04") (* ;; "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") (LET ((HIGHEST (INFILEP (PACKFILENAME 'EXTENSION 'DATABASE 'VERSION 'NIL 'BODY F))) DBF) (COND ((NULL HIGHEST) (* ;  "No file matches the name we gave, so punt.") NIL) ((SETQ DBF (DBFILE2 HIGHEST FILEDATES)) (* ; "The most recent one matches.") (CONS DBF FILEDATES)) (T (* ;  "Hunt back thru back versions looking for a matching one.") (for DBF in (REMOVE HIGHEST (FILDIR (PACKFILENAME 'EXTENSION 'DATABASE 'VERSION '* 'BODY F))) when (SETQ DBF (DBFILE2 DBF FILEDATES)) do (RETURN (CONS DBF FILEDATES]) (DBFILE2 [LAMBDA (DBF FILEDATES) (* ;  "Edited 24-Oct-2021 20:18 by rmk:") (* ; "Edited 28-Nov-90 12:42 by rmk:") (* ;; "Returns an open stream for DBF if it's the name of the database file matching FILEDATES. DBF is positioned after all the header material, and the reader environment is set up for it.") [RESETSAVE (SETQ DBF (OPENSTREAM DBF 'INPUT)) '(PROGN (CLOSEF? OLDVALUE] (SET-READER-ENVIRONMENT (READ-READER-ENVIRONMENT DBF (MAKE-READER-ENVIRONMENT *NEW-INTERLISP-MAKEFILE-ENVIRONMENT*) ) DBF) (* ;; "Skip the header stuff") (CL:WHEN [OR (EQ 0 (GETFILEPTR DBF)) (AND [EQ 'FILECREATED (CAR (LISTP (READ DBF] (EQ 'PRETTYCOMPRINT (CAR (LISTP (READ DBF] [EQ 'PROGN (CAR (LISTP (READ DBF] (COND ((STREQUAL (CAR FILEDATES) (CAR (READ DBF))) DBF) (T (CLOSEF DBF) NIL)))]) (LOAD [LAMBDA (FILE LDFLG PRINTFLG) (* lmm "29-APR-81 20:27") (SETQ FILE (OLDLOAD FILE LDFLG PRINTFLG)) (COND ((NEQ LDFLG '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 'MAKEFILES) (DEFINEQ (DUMPDB [LAMBDA (FILE PROPFLG) (* ; "Edited 12-May-2026 12:45 by rmk") (* ; "Edited 11-May-2026 14:41 by mth") (* ; "Edited 8-May-2026 16:18 by mth") (* ; "Edited 2-May-2026 17:32 by mth") (* ; "Edited 29-Apr-2026 17:42 by mth") (* ; "Edited 20-Feb-2024 23:45 by mth") (* ; "Edited 7-Feb-2024 18:26 by mth") (* ; "Edited 27-Oct-2021 10:51 by larry") (* ; "Edited 24-Oct-2021 16:24 by rmk:") (* ;; "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 MSFILETABLE SAVEDBFLG COPYRIGHTFLG DEFAULTCOPYRIGHTOWNER) (SPECVARS DEFAULTDATABASECOPYRIGHTOWNER)) (CL:WHEN (AND FILE (OR (LITATOM FILE) (STRINGP FILE))) (LET ((SAVEDCOPYRIGHTFLG COPYRIGHTFLG) (SAVEDDEFAULTCOPYRIGHTOWNER DEFAULTCOPYRIGHTOWNER)) (CL:UNWIND-PROTECT (PROG (DBFILE DBFN DBROOTFN FLCPR (FL (ROOTFILENAME FILE)) (FNS (FILEFNSLST FILE))) (SETQ DBFN (PACKFILENAME 'EXTENSION 'DATABASE 'VERSION NIL 'BODY FILE)) (SETQ DBROOTFN (ROOTFILENAME DBFN)) (CL:UNLESS (OR (EQ COPYRIGHTFLG 'NEVER) (NULL DEFAULTDATABASECOPYRIGHTOWNER) (GETPROP DBROOTFN 'COPYRIGHT)) (SELECTQ DEFAULTDATABASECOPYRIGHTOWNER ((NONE NEVER) (* ;;  "Set the COPYRIGHT to NONE (I.e., never mention it again.)") (/PUT DBROOTFN 'COPYRIGHT (LIST 'NONE))) (SAME (* ;;  "Same as the source file. If it doesn't have one, then just normal handling") (CL:WHEN (SETQ FLCPR (GETPROP FL 'COPYRIGHT)) (/PUT DBROOTFN 'COPYRIGHT (LIST (CAR FLCPR))))) (DEFAULT (* ;; "Use the general default for copyright") (SETQ COPYRIGHTFLG 'DEFAULT)) (PROGN (SETQ COPYRIGHTFLG 'DEFAULT) (* ;;  "Hopefully, DEFAULTDATABASECOPYRIGHTOWNER is one of the COPYRIGHTOWNERS keys") (SETQ DEFAULTCOPYRIGHTOWNER DEFAULTDATABASECOPYRIGHTOWNER)))) (COND (FNS) ((AND MSFILETABLE (TESTTABLE FL (CADR MSFILETABLE))) (* ;  "Always dump if this is a known file") (SETQ PROPFLG NIL)) (T (COND (PROPFLG (/REMPROP FL 'DATABASE)) (T (printout T T FILE " has no functions." T))) (RETURN))) (CL:WHEN [OR (NULL PROPFLG) (EQ (GETPROP FL 'DATABASE) 'YES) (EQ SAVEDBFLG 'YES) (AND MSFILETABLE (TESTTABLE FL (CADR MSFILETABLE] (CL:WHEN MSFILETABLE [STORETABLE FL MSFILETABLE (CAR (GETPROP FL 'FILEDATES]) [SETQ DBFILE (PRETTYDEF NIL DBFN `((P (PROGN (PRIN1 "Use LOADDB to load database files!" T) (ERROR!))) (E [PRINT (CAR (GETPROP ',FL 'FILEDATES] (DUMPDATABASE ',FNS] [COND (PROPFLG (PRINT (FULLNAME DBFILE) T)) (T (/PUT FL 'DATABASEFILENAME DBFILE) (* ;  "Remember that we have this file valid already.") (/PUT FL 'DATABASE 'YES] (* ;  "Take future note of the database on a user call") (RETURN DBFILE)))) (SETQ COPYRIGHTFLG SAVEDCOPYRIGHTFLG) (SETQ DEFAULTCOPYRIGHTOWNER SAVEDDEFAULTCOPYRIGHTOWNER)))]) (LOADDB [LAMBDA (FILE ASKFLAG) (* ; "Edited 11-May-2026 14:37 by mth") (* ; "Edited 24-Oct-2021 17:44 by rmk:") (* ; "Edited 7-Jul-92 09:57 by rmk:") (* ;; "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 MSFILETABLE MSARGTABLE DWIMWAIT LOADDBFLG)) (RESETLST [PROG* [TEM FORFILE (*READTABLE* (FIND-READTABLE "INTERLISP")) (*PACKAGE* (CL:FIND-PACKAGE "INTERLISP")) (NF (ROOTFILENAME FILE)) (DBSTREAM (DBFILE FILE ASKFLAG)) (DBFILE (FULLNAME (CAR DBSTREAM] (COND (DBSTREAM (SETQ FORFILE (CDR DBSTREAM)) (SETQ DBSTREAM (CAR DBSTREAM))) (T (COND ((NULL ASKFLAG) (PRINTOUT T "no database file found for " (NAMEFIELD FILE) T))) (RETURN))) (COND ([COND [ASKFLAG (COND ((EQ (GETPROP NF '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 'DATABASE) (YES T) (NO NIL) (SELECTQ LOADDBFLG (YES (/PUT NF 'DATABASE 'YES)) (NO (/PUT NF 'DATABASE 'NONE) NIL) (OR (AND MSFILETABLE (TESTTABLE NF (CADR MSFILETABLE))) (COND ((EQ (ASKUSER DWIMWAIT 'Y (LIST "load database for" NF)) 'Y) (/PUT NF 'DATABASE 'YES)) (T (/PUT NF 'DATABASE 'NO) NIL] (T (/PUT NF 'DATABASE 'YES] (LISPXPRINT (FULLNAME DBFILE) T) (* ; "DBSTREAM was opened in DBFILE") (RESETSAVE (INPUT DBSTREAM)) [COND ((EQ (SETQ TEM (READ)) 'FNS) (READ) (* ; "Old format: thrown away") (COND ((EQ (SETQ TEM (READ)) 'ARGS) (WHILE (READ)) (SETQ TEM (READ] (COND ((OR (EQ (CAR (LISTP TEM)) 'READATABASE) (EQ TEM 'STOP)) (COND ((NEQ TEM 'STOP) (* ; "It must be (READATABASE)") (READATABASE))) (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 'FILE)) WHEN (OR (EXPRP FN) (GETP FN '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 'DATABASEFILENAME DBFILE) (* ;  "Remember the name of the database we just loaded.") (RETURN (FULLNAME DBFILE])]) (MAKEDB [LAMBDA (F) (* DECLARATIONS%: UNDOABLE) (* ; "Edited 12-May-2026 12:37 by rmk") (* ; "Edited 11-May-2026 14:38 by mth") (* rmk%: " 9-NOV-83 02:56") (DECLARE (GLOBALVARS SAVEDBFLG MSFILETABLE DWIMWAIT)) (SETQ F (ROOTFILENAME 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 'FNS (FILECOMS F)) (OR (FMEMB (GETPROP F 'DATABASE) '(YES NO)) (FMEMB SAVEDBFLG '(YES NO)) (AND MSFILETABLE (TESTTABLE F (CADR MSFILETABLE))) (/PUT F 'DATABASE (COND ((EQ 'Y (ASKUSER DWIMWAIT 'N "Do you want a Masterscope Database for this file? ") ) 'YES) (T 'NO]) ) (PUTPROPS DATABASE PROPTYPE IGNORE) (RPAQ? LOADDBFLG 'ASK) (RPAQ? SAVEDBFLG 'ASK) (ADDTOVAR MAKEFILEFORMS (MAKEDB FILE)) (RPAQ? MSFILETABLE ) (RPAQ? DEFAULTDATABASECOPYRIGHTOWNER 'NEVER) (* ; "To permit MSHASH interface") (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 (1666 6814 (DBFILE 1676 . 3444) (DBFILE1 3446 . 4956) (DBFILE2 4958 . 6180) (LOAD 6182 . 6412) (LOADFROM 6414 . 6602) (MAKEFILE 6604 . 6812)) (6870 18839 (DUMPDB 6880 . 12478) (LOADDB 12480 . 17551) (MAKEDB 17553 . 18837))))) STOP