(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)


(FILECREATED "27-Oct-2021 10:55:18" {DSK}<home>larry>medley>library>DATABASEFNS.;7
 16051  

      changes to%:  (FNS DUMPDB)

      previous date%: "24-Oct-2021 20:18:51" {DSK}<home>larry>medley>library>DATABASEFNS.;6)


(* ; "
Copyright (c) 1986, 1990-1993 by Xerox Corporation.
")

(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))
                                                             (* ; "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 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 (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 (NAMEFIELD 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 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))
    (CL:WHEN (AND FILE (OR (LITATOM FILE)
                           (STRINGP FILE)))
        (PROG (DBFILE
 (FL (NAMEFIELD FILE))
                     (FNS (FILEFNSLST FILE)))
              (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 (PACKFILENAME 'EXTENSION 'DATABASE 'VERSION NIL
                                                     'BODY FILE)
                                      `((P (PROGN (PRIN1 "Use LOADDB to load database files!" T)
                                                  (ERROR!)))
                                        (E [PRINT (CAR (GETPROP ',FILE '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 databae on a user call")

                  (RETURN DBFILE))))])

(LOADDB

  [LAMBDA (FILE ASKFLAG)
                                (* ; "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 (NAMEFIELD 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 " NF 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)

                                                             (* 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 '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
 )



(* ; "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)
)
(PUTPROPS DATABASEFNS COPYRIGHT ("Xerox Corporation" 1986 1990 1991 1992 1993))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1679 6704 (DBFILE 1689 . 3334) (DBFILE1 3336 . 4846) (DBFILE2 4848 . 6070) (LOAD 6072
 . 6302) (LOADFROM 6304 . 6492) (MAKEFILE 6494 . 6702)) (6760 15499 (DUMPDB 6770 . 9534) (LOADDB 9536
 . 14411) (MAKEDB 14413 . 15497)))))
STOP