github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-01-25 20:06:44 +00:00
Code Issues Projects Releases Wiki Activity

Fix DST in IOCHAR, y2k problem in TMAX-daTE, DUMPDB (#547)

Browse Source 
* IOCHAR:  Fix daylight savings time
* TMAX: Y2K fix
   Also a little code cleanup, changing default font to TERMINAL from GACHA and making text more legible
* DATABASEFNS, ATBL:  DUMPDB with DEFINE-FILE-INFO

New database files will have standard headers, then a little special stuff for LOADDB to synchronize, old database files default to a new interlisp environment. 

 MAKE-READER-ENVIRONMENT in ATBL extended for easier specification, plus better type-testing.

* Remove duplicate comment
This commit is contained in:
rmkaplan
2021-10-27 12:05:15 -07:00
committed by GitHub
parent 01de5a2324
commit 18f5da85fd
10 changed files with 557 additions and 547 deletions
Download Patch File Download Diff File Expand all files Collapse all files

308
library/DATABASEFNS
View File

@@ -1,19 +1,22 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED " 3-May-93 18:44:36" "{DSK}<project>lfg>parser>DATABASEFNS.;4" 17283
(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%: " 7-Jul-92 09:57:14" "{DSK}<project>lfg>parser>DATABASEFNS.;3")
previous date%: "24-Oct-2021 20:18:51" {DSK}<home>larry>medley>library>DATABASEFNS.;6)
(* ; "
Copyright (c) 1986, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights reserved.
Copyright (c) 1986, 1990-1993 by Xerox Corporation.
")
(PRETTYCOMPRINT DATABASEFNSCOMS)
(RPAQQ DATABASEFNSCOMS
[(* Does automatic Masterscope database maintenance)
[
(* ;; "Does automatic Masterscope database maintenance")
[DECLARE%: FIRST (P (VIRGINFN 'LOAD T)
(MOVD? 'LOAD 'OLDLOAD)
(VIRGINFN 'LOADFROM T)
@@ -28,16 +31,15 @@ Copyright (c) 1986, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights res
(INITVARS (LOADDBFLG 'ASK)
(SAVEDBFLG 'ASK))
(ADDVARS (MAKEFILEFORMS (MAKEDB FILE)))
(* To permit MSHASH interface)
(INITVARS (MSHASHFILENAME)
(MSFILETABLE))
(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)
(* ;; "Does automatic Masterscope database maintenance")
(DECLARE%: FIRST
@@ -56,78 +58,81 @@ Copyright (c) 1986, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights res
(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)
[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)))
((EQ (FILENAMEFIELD FILE 'EXTENSION)
COMPILE.EXT) (* Map compiled file into symbolic
 name)
((MEMB (FILENAMEFIELD FILE 'EXTENSION)
*COMPILED-EXTENSIONS*) (* ;
 "Map compiled file into symbolic name")
(SETQ FILE (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY FILE]
(PROG [(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 (RETURN (DBFILE1 FILE FILEDATES])
(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) (* 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)
[LAMBDA (F FILEDATES) (* ; "Edited 24-Oct-2021 15:43 by rmk:")
(* jds "25-Sep-86 20:04")
(PROG ((HIGHEST (INFILEP (PACKFILENAME 'EXTENSION 'DATABASE 'VERSION 'NIL 'BODY F)))
DBF)
(RETURN (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])
(* ;; "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 28-Nov-90 12:42 by rmk:")
(* T if DBF is the name of the
 database file matching FILEDATES)
[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)
(* The close is done in the LOADDB RESETLST, except when a candidate file isn't
 correct)
(* ;; "Skip the header stuff")
(SKREAD DBF) (* Skip LOAD error message)
(COND
([STREQUAL (CAR FILEDATES)
(CAR (READ DBF (FIND-READTABLE "INTERLISP"]
DBF)
(T (CLOSEF DBF)
NIL])
(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")
@@ -156,88 +161,62 @@ Copyright (c) 1986, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights res
(DEFINEQ
(DUMPDB
[LAMBDA (FILE PROPFLG) (* ; "Edited 3-May-93 18:44 by rmk:")
[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.)
(* ;; "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)
(* ;;
 "The FILE check is because MAKEFILE returns a list when it doesn't understand the options")
(DECLARE (GLOBALVARS MSHASHFILENAME MSFILETABLE SAVEDBFLG))
(AND FILE (OR (LITATOM FILE)
(STRINGP 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 'DATABASE))
(T (printout T T FILE " has no functions." T)))
(RETURN)))
(SETQ FNS FFNS)
(COND
([OR (NULL PROPFLG)
(EQ (GETPROP FL 'DATABASE)
'YES)
(EQ SAVEDBFLG '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 (OPENSTREAM (PACKFILENAME 'EXTENSION 'DATABASE
'VERSION NIL 'BODY FILE)
'OUTPUT
'NEW))
'(PROGN (CLOSEF? OLDVALUE)
(AND RESETSTATE (DELFILE OLDVALUE]
(RESETSAVE (OUTPUT DBFILE))
(RESETSAVE (SETREADTABLE (FIND-READTABLE "INTERLISP")))
(RESETSAVE (CL:IN-PACKAGE "INTERLISP")
(LIST 'CL:IN-PACKAGE (CL:PACKAGE-NAME *PACKAGE*)))
(PRIN1 "(PROGN (PRIN1 %"Use LOADDB to load database files!%
%" T) (ERROR!))%
"
)
[AND MSFILETABLE (STORETABLE FL MSFILETABLE (PRINT (CAR (GETPROP FL
'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 (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 (FULLNAME DBFILE])
(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 7-Jul-92 09:57 by rmk:")
[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.")
(* ;; "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 LOADDBFLG))
(DECLARE (GLOBALVARS MSFILETABLE MSARGTABLE DWIMWAIT LOADDBFLG))
(RESETLST
[PROG* [TEM NEWFNS FORFILE (*READTABLE* (FIND-READTABLE "INTERLISP"))
[PROG* [TEM FORFILE (*READTABLE* (FIND-READTABLE "INTERLISP"))
(*PACKAGE* (CL:FIND-PACKAGE "INTERLISP"))
(NF (NAMEFIELD FILE))
(DBSTREAM (DBFILE FILE ASKFLAG))
@@ -253,8 +232,8 @@ Copyright (c) 1986, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights res
([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.")
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)
@@ -275,42 +254,37 @@ Copyright (c) 1986, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights res
NIL]
(T (/PUT NF 'DATABASE 'YES]
(LISPXPRINT (FULLNAME DBFILE)
T) (* ; "DBSTREAM was opened in DBFILE")
T) (* ; "DBSTREAM was opened in DBFILE")
(RESETSAVE (INPUT DBSTREAM))
[COND
((EQ (SETQ TEM (READ))
'FNS)
(SETQ NEWFNS (READ))
(READ) (* ; "Old format: thrown away")
(COND
((EQ (SETQ TEM (READ))
'ARGS)
[COND
[MSHASHFILENAME (BIND F WHILE (SETQ F (READ))
DO (STORETABLE F MSARGTABLE (READ]
(T (WHILE (READ]
(WHILE (READ))
(SETQ TEM (READ]
(COND
((OR (EQ (CAR (LISTP TEM))
'READATABASE)
(EQ TEM 'STOP))
(COND
((NEQ TEM 'STOP) (* ; "It must be (READATABASE)")
((NEQ TEM '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.")
(* ;
 "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")
(* ; "So that value of LOADDB is NIL")
(SETQ DBFILE NIL)))
(/PUT NF 'DATABASEFILENAME DBFILE) (* ;
 "Remember the name of the database we just loaded.")
(/PUT NF 'DATABASEFILENAME DBFILE) (* ;
 "Remember the name of the database we just loaded.")
(RETURN (FULLNAME DBFILE])])
(MAKEDB
@@ -345,14 +319,12 @@ Copyright (c) 1986, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights res
(ADDTOVAR MAKEFILEFORMS (MAKEDB FILE))
(* To permit MSHASH interface)
(RPAQ? MSHASHFILENAME )
(RPAQ? MSFILETABLE )
(* ; "To permit MSHASH interface")
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
@@ -367,7 +339,7 @@ Copyright (c) 1986, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights res
)
(PUTPROPS DATABASEFNS COPYRIGHT ("Xerox Corporation" 1986 1990 1991 1992 1993))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1637 6218 (DBFILE 1647 . 3295) (DBFILE1 3297 . 4820) (DBFILE2 4822 . 5584) (LOAD 5586
. 5816) (LOADFROM 5818 . 6006) (MAKEFILE 6008 . 6216)) (6274 16706 (DUMPDB 6284 . 10572) (LOADDB
10574 . 15618) (MAKEDB 15620 . 16704)))))
(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

BIN
library/DATABASEFNS.LCOM
View File

Binary file not shown.