Compare commits
1 Commits
medley-260
...
master
| Author | SHA1 | Date | |
|---|---|---|---|
|
0fc3e9e8e4 |
@@ -1,19 +1,15 @@
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
|
||||
|
||||
(FILECREATED " 2-May-2026 17:38:46" {DSK}<home>matt>Interlisp>medley>library>DATABASEFNS.;4 18684
|
||||
(FILECREATED "12-May-2026 15:33:42" {DSK}<home>matt>Interlisp>medley>library>DATABASEFNS.;5 19557
|
||||
|
||||
:EDIT-BY "mth"
|
||||
|
||||
:CHANGES-TO (FNS DUMPDB)
|
||||
|
||||
:PREVIOUS-DATE "29-Apr-2026 17:43:56" {DSK}<home>matt>Interlisp>medley>library>DATABASEFNS.;2
|
||||
:PREVIOUS-DATE "12-May-2026 12:45:18" {DSK}<home>matt>Interlisp>medley>library>DATABASEFNS.;4
|
||||
)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1986, 1990-1993, 2024, 2026 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT DATABASEFNSCOMS)
|
||||
|
||||
(RPAQQ DATABASEFNSCOMS
|
||||
@@ -62,7 +58,8 @@ Copyright (c) 1986, 1990-1993, 2024, 2026 by Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(DBFILE
|
||||
[LAMBDA (FILE ASKFLAG) (* ; "Edited 24-Oct-2021 16:50 by rmk:")
|
||||
[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.")
|
||||
@@ -73,13 +70,13 @@ Copyright (c) 1986, 1990-1993, 2024, 2026 by Xerox Corporation.
|
||||
[COND
|
||||
((NULL FILE)
|
||||
(SETQ FILE (INPUT)))
|
||||
((MEMB (FILENAMEFIELD FILE 'EXTENSION)
|
||||
((MEMB (U-CASE (FILENAMEFIELD FILE 'EXTENSION))
|
||||
*COMPILED-EXTENSIONS*) (* ;
|
||||
"Map compiled file into symbolic name")
|
||||
"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)
|
||||
(CAR (GETPROP (ROOTFILENAME FILE)
|
||||
'FILEDATES]
|
||||
([SETQ FILE (COND
|
||||
(ASKFLAG (INFILEP FILE))
|
||||
@@ -165,14 +162,22 @@ Copyright (c) 1986, 1990-1993, 2024, 2026 by Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(DUMPDB
|
||||
[LAMBDA (FILE PROPFLG) (* ; "Edited 2-May-2026 17:32 by mth")
|
||||
[LAMBDA (FILE PROPFLG) (* ; "Edited 12-May-2026 15:31 by mth")
|
||||
(* ; "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.")
|
||||
(* ;; "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")
|
||||
|
||||
@@ -183,72 +188,73 @@ Copyright (c) 1986, 1990-1993, 2024, 2026 by Xerox Corporation.
|
||||
(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)
|
||||
(* ;;
|
||||
(PROG* (DBFILE DBFN DBROOTFN FLCPR (FL (ROOTFILENAME FILE))
|
||||
(FNS (FILEFNSLST FL)))
|
||||
(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
|
||||
(* ;;
|
||||
(/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")
|
||||
(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)
|
||||
(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)))
|
||||
(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)
|
||||
(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] (* ;
|
||||
(/PUT FL 'DATABASE 'YES] (* ;
|
||||
"Take future note of the database on a user call")
|
||||
(RETURN DBFILE))))
|
||||
(RETURN DBFILE))))
|
||||
(SETQ COPYRIGHTFLG SAVEDCOPYRIGHTFLG)
|
||||
(SETQ DEFAULTCOPYRIGHTOWNER SAVEDDEFAULTCOPYRIGHTOWNER)))])
|
||||
|
||||
(LOADDB
|
||||
[LAMBDA (FILE ASKFLAG) (* ; "Edited 24-Oct-2021 17:44 by rmk:")
|
||||
[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.")
|
||||
@@ -257,7 +263,7 @@ Copyright (c) 1986, 1990-1993, 2024, 2026 by Xerox Corporation.
|
||||
(RESETLST
|
||||
[PROG* [TEM FORFILE (*READTABLE* (FIND-READTABLE "INTERLISP"))
|
||||
(*PACKAGE* (CL:FIND-PACKAGE "INTERLISP"))
|
||||
(NF (NAMEFIELD FILE))
|
||||
(NF (ROOTFILENAME FILE))
|
||||
(DBSTREAM (DBFILE FILE ASKFLAG))
|
||||
(DBFILE (FULLNAME (CAR DBSTREAM]
|
||||
(COND
|
||||
@@ -265,14 +271,15 @@ Copyright (c) 1986, 1990-1993, 2024, 2026 by Xerox Corporation.
|
||||
(SETQ DBSTREAM (CAR DBSTREAM)))
|
||||
(T (COND
|
||||
((NULL ASKFLAG)
|
||||
(PRINTOUT T "no database file found for " NF T)))
|
||||
(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.")
|
||||
"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)
|
||||
@@ -313,28 +320,30 @@ Copyright (c) 1986, 1990-1993, 2024, 2026 by Xerox Corporation.
|
||||
(READATABASE)))
|
||||
(AND MSFILETABLE (STORETABLE NF MSFILETABLE FORFILE))
|
||||
(* ;
|
||||
"This is done whether or not there is a hashfile.")
|
||||
"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)))
|
||||
"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.")
|
||||
"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 (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)
|
||||
(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))
|
||||
@@ -378,9 +387,8 @@ Copyright (c) 1986, 1990-1993, 2024, 2026 by Xerox Corporation.
|
||||
|
||||
(RESETSAVE DWIMIFYCOMPFLG T)
|
||||
)
|
||||
(PUTPROPS DATABASEFNS COPYRIGHT ("Xerox Corporation" 1986 1990 1991 1992 1993 2024 2026))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1783 6808 (DBFILE 1793 . 3438) (DBFILE1 3440 . 4950) (DBFILE2 4952 . 6174) (LOAD 6176
|
||||
. 6406) (LOADFROM 6408 . 6596) (MAKEFILE 6598 . 6806)) (6864 18072 (DUMPDB 6874 . 12107) (LOADDB
|
||||
12109 . 16984) (MAKEDB 16986 . 18070)))))
|
||||
(FILEMAP (NIL (1708 6856 (DBFILE 1718 . 3486) (DBFILE1 3488 . 4998) (DBFILE2 5000 . 6222) (LOAD 6224
|
||||
. 6454) (LOADFROM 6456 . 6644) (MAKEFILE 6646 . 6854)) (6912 19035 (DUMPDB 6922 . 12674) (LOADDB
|
||||
12676 . 17747) (MAKEDB 17749 . 19033)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user