github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-04-18 17:27:25 +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") (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 3-May-93 18:44:36" "{DSK}<project>lfg>parser>DATABASEFNS.;4" 17283
(FILECREATED "27-Oct-2021 10:55:18" {DSK}<home>larry>medley>library>DATABASEFNS.;7 16051
changes to%: (FNS DUMPDB) 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) (PRETTYCOMPRINT DATABASEFNSCOMS)
(RPAQQ DATABASEFNSCOMS (RPAQQ DATABASEFNSCOMS
[(* Does automatic Masterscope database maintenance) [
(* ;; "Does automatic Masterscope database maintenance")
[DECLARE%: FIRST (P (VIRGINFN 'LOAD T) [DECLARE%: FIRST (P (VIRGINFN 'LOAD T)
(MOVD? 'LOAD 'OLDLOAD) (MOVD? 'LOAD 'OLDLOAD)
(VIRGINFN 'LOADFROM T) (VIRGINFN 'LOADFROM T)
@@ -28,16 +31,15 @@ Copyright (c) 1986, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights res
(INITVARS (LOADDBFLG 'ASK) (INITVARS (LOADDBFLG 'ASK)
(SAVEDBFLG 'ASK)) (SAVEDBFLG 'ASK))
(ADDVARS (MAKEFILEFORMS (MAKEDB FILE))) (ADDVARS (MAKEFILEFORMS (MAKEDB FILE)))
(* To permit MSHASH interface) (INITVARS (MSFILETABLE))
(INITVARS (MSHASHFILENAME) (* ; "To permit MSHASH interface")
(MSFILETABLE))
(LOCALVARS . T) (LOCALVARS . T)
(BLOCKS (LOADDB LOADDB DBFILE DBFILE1 DBFILE2 (NOLINKFNS . T))) (BLOCKS (LOADDB LOADDB DBFILE DBFILE1 DBFILE2 (NOLINKFNS . T)))
(DECLARE%: EVAL@COMPILE DONTCOPY (P (RESETSAVE DWIMIFYCOMPFLG T]) (DECLARE%: EVAL@COMPILE DONTCOPY (P (RESETSAVE DWIMIFYCOMPFLG T])
(* Does automatic Masterscope database maintenance) (* ;; "Does automatic Masterscope database maintenance")
(DECLARE%: FIRST (DECLARE%: FIRST
@@ -56,78 +58,81 @@ Copyright (c) 1986, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights res
(DEFINEQ (DEFINEQ
(DBFILE (DBFILE
[LAMBDA (FILE ASKFLAG) (* lmm "29-APR-81 20:27") [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 (* ;; "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.")
 from, if it was copied. Returns NIL if no database file is found, else
 (fulldbfilename . filedates)%, where filedates identifies the name under which (* ;; "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")
 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)) (DECLARE (GLOBALVARS COMPILE.EXT FILERDTBL))
[COND [COND
((NULL FILE) ((NULL FILE)
(SETQ FILE (INPUT))) (SETQ FILE (INPUT)))
((EQ (FILENAMEFIELD FILE 'EXTENSION) ((MEMB (FILENAMEFIELD FILE 'EXTENSION)
COMPILE.EXT) (* Map compiled file into symbolic *COMPILED-EXTENSIONS*) (* ;
 name)  "Map compiled file into symbolic name")
(SETQ FILE (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY FILE] (SETQ FILE (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY FILE]
(PROG [(FILEDATES (COND (LET [(FILEDATES (COND
[(AND (NULL (FILENAMEFIELD FILE 'VERSION)) [(AND (NULL (FILENAMEFIELD FILE 'VERSION))
(CAR (GETPROP (NAMEFIELD FILE) (CAR (GETPROP (NAMEFIELD FILE)
'FILEDATES] 'FILEDATES]
([SETQ FILE (COND ([SETQ FILE (COND
(ASKFLAG (INFILEP FILE)) (ASKFLAG (INFILEP FILE))
(T (FINDFILE FILE] (T (FINDFILE FILE]
(CONS (FILEDATE FILE) (CONS (FILEDATE FILE)
FILE] FILE]
(AND FILEDATES (RETURN (DBFILE1 FILE FILEDATES]) (AND FILEDATES (DBFILE1 FILE FILEDATES])
(DBFILE1 (DBFILE1
[LAMBDA (F FILEDATES) (* jds "25-Sep-86 20:04") [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)
(PROG ((HIGHEST (INFILEP (PACKFILENAME 'EXTENSION 'DATABASE 'VERSION 'NIL 'BODY F))) (* ;; "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")
DBF)
(RETURN (COND (LET ((HIGHEST (INFILEP (PACKFILENAME 'EXTENSION 'DATABASE 'VERSION 'NIL 'BODY F)))
((NULL HIGHEST) (* ; DBF)
 "No file matches the name we gave, so punt.") (COND
NIL) ((NULL HIGHEST) (* ;
((SETQ DBF (DBFILE2 HIGHEST FILEDATES)) (* ; "The most recent one matches.")  "No file matches the name we gave, so punt.")
(CONS DBF FILEDATES)) NIL)
(T (* ; ((SETQ DBF (DBFILE2 HIGHEST FILEDATES)) (* ; "The most recent one matches.")
 "Hunt back thru back versions looking for a matching one.") (CONS DBF FILEDATES))
(for DBF in (REMOVE HIGHEST (FILDIR (PACKFILENAME 'EXTENSION 'DATABASE (T (* ;
'VERSION  "Hunt back thru back versions looking for a matching one.")
'* (for DBF in (REMOVE HIGHEST (FILDIR (PACKFILENAME 'EXTENSION 'DATABASE
'BODY F))) 'VERSION
when (SETQ DBF (DBFILE2 DBF FILEDATES)) '*
do (RETURN (CONS DBF FILEDATES]) 'BODY F)))
when (SETQ DBF (DBFILE2 DBF FILEDATES))
do (RETURN (CONS DBF FILEDATES])
(DBFILE2 (DBFILE2
[LAMBDA (DBF FILEDATES) (* ; "Edited 28-Nov-90 12:42 by rmk:") [LAMBDA (DBF FILEDATES) (* ;
(* T if DBF is the name of the  "Edited 24-Oct-2021 20:18 by rmk:")
 database file matching FILEDATES) (* ; "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)) [RESETSAVE (SETQ DBF (OPENSTREAM DBF 'INPUT))
'(PROGN (CLOSEF? OLDVALUE] '(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 (* ;; "Skip the header stuff")
 correct)
(SKREAD DBF) (* Skip LOAD error message) (CL:WHEN [OR (EQ 0 (GETFILEPTR DBF))
(COND (AND [EQ 'FILECREATED (CAR (LISTP (READ DBF]
([STREQUAL (CAR FILEDATES) (EQ 'PRETTYCOMPRINT (CAR (LISTP (READ DBF]
(CAR (READ DBF (FIND-READTABLE "INTERLISP"] [EQ 'PROGN (CAR (LISTP (READ DBF]
DBF) (COND
(T (CLOSEF DBF) ((STREQUAL (CAR FILEDATES)
NIL]) (CAR (READ DBF)))
DBF)
(T (CLOSEF DBF)
NIL)))])
(LOAD (LOAD
[LAMBDA (FILE LDFLG PRINTFLG) (* lmm "29-APR-81 20:27") [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 (DEFINEQ
(DUMPDB (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. (* ;; "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.")
 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)) (DECLARE (GLOBALVARS MSFILETABLE SAVEDBFLG))
(AND FILE (OR (LITATOM FILE) (CL:WHEN (AND FILE (OR (LITATOM FILE)
(STRINGP FILE)) (STRINGP FILE)))
(PROG (DBFILE (FL (NAMEFIELD FILE)) (PROG (DBFILE (FL (NAMEFIELD FILE))
FNS (FNS (FILEFNSLST FILE)))
(FFNS (FILEFNSLST FILE))) (COND
(COND (FNS)
(FFNS) ((AND MSFILETABLE (TESTTABLE FL (CADR MSFILETABLE)))
((AND MSFILETABLE (TESTTABLE FL (CADR MSFILETABLE))) (* ;
(* Always dump if this is a known  "Always dump if this is a known file")
 file) (SETQ PROPFLG NIL))
(SETQ PROPFLG NIL)) (T (COND
(T (COND (PROPFLG (/REMPROP FL 'DATABASE))
(PROPFLG (/REMPROP FL 'DATABASE)) (T (printout T T FILE " has no functions." T)))
(T (printout T T FILE " has no functions." T))) (RETURN)))
(RETURN))) (CL:WHEN [OR (NULL PROPFLG)
(SETQ FNS FFNS) (EQ (GETPROP FL 'DATABASE)
(COND 'YES)
([OR (NULL PROPFLG) (EQ SAVEDBFLG 'YES)
(EQ (GETPROP FL 'DATABASE) (AND MSFILETABLE (TESTTABLE FL (CADR MSFILETABLE]
'YES) (CL:WHEN MSFILETABLE
(EQ SAVEDBFLG 'YES) [STORETABLE FL MSFILETABLE (CAR (GETPROP FL 'FILEDATES])
(AND MSFILETABLE (TESTTABLE FL (CADR MSFILETABLE] [SETQ DBFILE (PRETTYDEF NIL (PACKFILENAME 'EXTENSION 'DATABASE 'VERSION NIL
(* If MSHASH is loaded, only dump 'BODY FILE)
 functions in the local database) `((P (PROGN (PRIN1 "Use LOADDB to load database files!" T)
[COND (ERROR!)))
(MSHASHFILENAME (SETQ FNS (for FN in FNS (E [PRINT (CAR (GETPROP ',FILE 'FILEDATES]
when (PROGN (UPDATEFN FN) (DUMPDATABASE ',FNS]
(LOCALFNP FN)) collect FN] [COND
(RESETLST (PROPFLG (PRINT (FULLNAME DBFILE)
[RESETSAVE (SETQ DBFILE (OPENSTREAM (PACKFILENAME 'EXTENSION 'DATABASE T))
'VERSION NIL 'BODY FILE) (T (/PUT FL 'DATABASEFILENAME DBFILE) (* ;
'OUTPUT  "Remember that we have this file valid already.")
'NEW)) (/PUT FL 'DATABASE 'YES] (* ;
'(PROGN (CLOSEF? OLDVALUE)  "Take future note of the databae on a user call")
(AND RESETSTATE (DELFILE OLDVALUE] (RETURN DBFILE))))])
(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])
(LOADDB (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 (RESETLST
[PROG* [TEM NEWFNS FORFILE (*READTABLE* (FIND-READTABLE "INTERLISP")) [PROG* [TEM FORFILE (*READTABLE* (FIND-READTABLE "INTERLISP"))
(*PACKAGE* (CL:FIND-PACKAGE "INTERLISP")) (*PACKAGE* (CL:FIND-PACKAGE "INTERLISP"))
(NF (NAMEFIELD FILE)) (NF (NAMEFIELD FILE))
(DBSTREAM (DBFILE FILE ASKFLAG)) (DBSTREAM (DBFILE FILE ASKFLAG))
@@ -253,8 +232,8 @@ Copyright (c) 1986, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights res
([COND ([COND
[ASKFLAG (COND [ASKFLAG (COND
((EQ (GETPROP NF 'DATABASEFILENAME) ((EQ (GETPROP NF 'DATABASEFILENAME)
DBFILE) (* ; 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) (PRINTOUT T "Database " DBFILE " already loaded." T)
NIL) NIL)
(T (SELECTQ (GETPROP NF 'DATABASE) (T (SELECTQ (GETPROP NF 'DATABASE)
@@ -275,42 +254,37 @@ Copyright (c) 1986, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights res
NIL] NIL]
(T (/PUT NF 'DATABASE 'YES] (T (/PUT NF 'DATABASE 'YES]
(LISPXPRINT (FULLNAME DBFILE) (LISPXPRINT (FULLNAME DBFILE)
T) (* ; "DBSTREAM was opened in DBFILE") T) (* ; "DBSTREAM was opened in DBFILE")
(RESETSAVE (INPUT DBSTREAM)) (RESETSAVE (INPUT DBSTREAM))
[COND [COND
((EQ (SETQ TEM (READ)) ((EQ (SETQ TEM (READ))
'FNS) 'FNS)
(SETQ NEWFNS (READ)) (READ) (* ; "Old format: thrown away")
(COND (COND
((EQ (SETQ TEM (READ)) ((EQ (SETQ TEM (READ))
'ARGS) 'ARGS)
[COND (WHILE (READ))
[MSHASHFILENAME (BIND F WHILE (SETQ F (READ))
DO (STORETABLE F MSARGTABLE (READ]
(T (WHILE (READ]
(SETQ TEM (READ] (SETQ TEM (READ]
(COND (COND
((OR (EQ (CAR (LISTP TEM)) ((OR (EQ (CAR (LISTP TEM))
'READATABASE) 'READATABASE)
(EQ TEM 'STOP)) (EQ TEM 'STOP))
(COND (COND
((NEQ TEM 'STOP) (* ; "It must be (READATABASE)") ((NEQ TEM 'STOP) (* ; "It must be (READATABASE)")
(READATABASE))) (READATABASE)))
(COND
(MSHASHFILENAME (UPDATECONTAINS NF NEWFNS)))
(AND MSFILETABLE (STORETABLE NF MSFILETABLE FORFILE)) (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) (* ; (UPDATEFILES) (* ;
 "Mark any edited fns as needing to be reanalyzed.")  "Mark any edited fns as needing to be reanalyzed.")
(FOR FN IN (CDR (GETP NF 'FILE)) (FOR FN IN (CDR (GETP NF 'FILE))
WHEN (OR (EXPRP FN) WHEN (OR (EXPRP FN)
(GETP FN 'EXPR)) DO (MSMARKCHANGED FN))) (GETP FN 'EXPR)) DO (MSMARKCHANGED FN)))
(T (PRINTOUT T T DBFILE " is not a database file!" T) (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))) (SETQ DBFILE NIL)))
(/PUT NF 'DATABASEFILENAME DBFILE) (* ; (/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])]) (RETURN (FULLNAME DBFILE])])
(MAKEDB (MAKEDB
@@ -345,14 +319,12 @@ Copyright (c) 1986, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights res
(ADDTOVAR MAKEFILEFORMS (MAKEDB FILE)) (ADDTOVAR MAKEFILEFORMS (MAKEDB FILE))
(* To permit MSHASH interface)
(RPAQ? MSHASHFILENAME )
(RPAQ? MSFILETABLE ) (RPAQ? MSFILETABLE )
(* ; "To permit MSHASH interface")
(DECLARE%: DOEVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T) (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)) (PUTPROPS DATABASEFNS COPYRIGHT ("Xerox Corporation" 1986 1990 1991 1992 1993))
(DECLARE%: DONTCOPY (DECLARE%: DONTCOPY
(FILEMAP (NIL (1637 6218 (DBFILE 1647 . 3295) (DBFILE1 3297 . 4820) (DBFILE2 4822 . 5584) (LOAD 5586 (FILEMAP (NIL (1679 6704 (DBFILE 1689 . 3334) (DBFILE1 3336 . 4846) (DBFILE2 4848 . 6070) (LOAD 6072
. 5816) (LOADFROM 5818 . 6006) (MAKEFILE 6008 . 6216)) (6274 16706 (DUMPDB 6284 . 10572) (LOADDB . 6302) (LOADFROM 6304 . 6492) (MAKEFILE 6494 . 6702)) (6760 15499 (DUMPDB 6770 . 9534) (LOADDB 9536
10574 . 15618) (MAKEDB 15620 . 16704))))) . 14411) (MAKEDB 14413 . 15497)))))
STOP STOP

BIN
library/DATABASEFNS.LCOM
View File

Binary file not shown.

207
lispusers/TMAX
View File

@@ -1,22 +1,26 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "19-May-99 08:41:45" {DSK}<project>medley3.5>lispusers>TMAX.;5 28668
changes to%: (MACROS MAKE.XREFOBJ.IMAGEFNS) (FILECREATED "24-Oct-2021 23:45:20" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>TMAX.;4 31402
previous date%: "18-May-99 22:44:24" {DSK}<project>medley3.5>lispusers>TMAX.;3) changes to%: (VARS TMAXCOMS)
(FNS GET.TSP.FONT.FAMILY)
previous date%: "24-Oct-2021 22:06:32"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>TMAX.;2)
(* ; " (* ; "
Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved. Copyright (c) 1987, 1997, 1999 by Stanford University.
") ")
(PRETTYCOMPRINT TMAXCOMS) (PRETTYCOMPRINT TMAXCOMS)
(RPAQQ TMAXCOMS (RPAQQ TMAXCOMS
( (* ; ( (* ;
 "Developed under support from NIH grant RR-00785.")  "Developed under support from NIH grant RR-00785.")
(* ; (* ;
 "Written by Frank Gilmurray and Sami Shaio.")  "Written by Frank Gilmurray and Sami Shaio.")
(FILES (COMPILED SYSLOAD) (FILES (COMPILED SYSLOAD)
TEDIT FREEMENU) TEDIT FREEMENU)
(VARS TMAX.FILE.LIST) (VARS TMAX.FILE.LIST)
@@ -27,38 +31,38 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
(P (DOFILESLOAD TMAX.FILE.LIST)) (P (DOFILESLOAD TMAX.FILE.LIST))
(* ;;; "Free Menu data structures") (* ;;; "Free Menu data structures")
(VARS TSP.FM.DESC IMAGEOBJ.MENU.ITEMS) (VARS TSP.FM.DESC IMAGEOBJ.MENU.ITEMS)
(* ;;; "Free Menu functions") (* ;;; "Free Menu functions")
(FNS TSP.DISPLAY.FMMENU TSP.SETUP.FILENAMES TSP.SETUP.FMMENU TSP.FMMENU TSP.FM.APPLY (FNS TSP.DISPLAY.FMMENU TSP.SETUP.FILENAMES TSP.SETUP.FMMENU TSP.FMMENU TSP.FM.APPLY
UPDATE.ALL DOWNDATE.ALL TSP.FUNCTION.HOOKS TSP.GETFN TSP.PUTFN) UPDATE.ALL DOWNDATE.ALL TSP.FUNCTION.HOOKS TSP.GETFN TSP.PUTFN)
(* ;;; "Free Menu toggle functions") (* ;;; "Free Menu toggle functions")
(FNS AutoUpdate.TOGGLE UPDATE? NGROUP.Menu.TOGGLE NGROUPMENU.ENABLED? (FNS AutoUpdate.TOGGLE UPDATE? NGROUP.Menu.TOGGLE NGROUPMENU.ENABLED?
NGROUP.Text-Before.TOGGLE TEXTBEFORE.ENABLED? NGROUP.Text-After.TOGGLE NGROUP.Text-Before.TOGGLE TEXTBEFORE.ENABLED? NGROUP.Text-After.TOGGLE
TEXTAFTER.ENABLED? Manual.Index.TOGGLE MANUALINDEX.ENABLED?) TEXTAFTER.ENABLED? Manual.Index.TOGGLE MANUALINDEX.ENABLED?)
(* ;;; "TSP font stuff") (* ;;; "TSP font stuff")
(FNS GET.TSP.FONT GET.TSP.FONT.FAMILY GET.TSP.FONT.SIZE GET.TSP.FONT.FACE ABBREVIATE.FONT (FNS GET.TSP.FONT GET.TSP.FONT.FAMILY GET.TSP.FONT.SIZE GET.TSP.FONT.FACE ABBREVIATE.FONT
TMAX.SHADEOBJ) TMAX.SHADEOBJ)
(* ;;; "Collect ImageObjects") (* ;;; "Collect ImageObjects")
(FNS TSP.LIST.OF.OBJECTS) (FNS TSP.LIST.OF.OBJECTS)
(GLOBALVARS GP.DefaultFont GP.DefaultShade) (GLOBALVARS GP.DefaultFont GP.DefaultShade)
(MACROS MAKE.DATEOBJ.IMAGEFNS MAKE.NUMBEROBJ.IMAGEFNS MAKE.REGMARKOBJ.IMAGEFNS (MACROS MAKE.DATEOBJ.IMAGEFNS MAKE.NUMBEROBJ.IMAGEFNS MAKE.REGMARKOBJ.IMAGEFNS
MAKE.XREFOBJ.IMAGEFNS) MAKE.XREFOBJ.IMAGEFNS)
(VARS (GP.DefaultFont (FONTCREATE 'GACHA 10)) (VARS (GP.DefaultFont (FONTCREATE 'TERMINAL 10))
(GP.DefaultShade 10260) (GP.DefaultShade 1024)
(\NUMBEROBJ.IMAGEFNS (MAKE.NUMBEROBJ.IMAGEFNS)) (\NUMBEROBJ.IMAGEFNS (MAKE.NUMBEROBJ.IMAGEFNS))
(\DATEOBJ.IMAGEFNS (MAKE.DATEOBJ.IMAGEFNS)) (\DATEOBJ.IMAGEFNS (MAKE.DATEOBJ.IMAGEFNS))
(\REGMARKOBJ.IMAGEFNS (MAKE.REGMARKOBJ.IMAGEFNS)) (\REGMARKOBJ.IMAGEFNS (MAKE.REGMARKOBJ.IMAGEFNS))
@@ -134,7 +138,7 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
(LABEL "Known References" ID KNOWNREF SELECTEDFN TSP.FM.APPLY) (LABEL "Known References" ID KNOWNREF SELECTEDFN TSP.FM.APPLY)
(LABEL "Reference By" TYPE STATE MENUITEMS (Ask Value Page) (LABEL "Reference By" TYPE STATE MENUITEMS (Ask Value Page)
INITSTATE Value LINKS (DISPLAY DEFAULTREF)) INITSTATE Value LINKS (DISPLAY DEFAULTREF))
(LABEL "" TYPE DISPLAY ID DEFAULTREF FONT (GACHA 10 MRR))) (LABEL "" TYPE DISPLAY ID DEFAULTREF FONT (TERMINAL 10 MRR)))
((LABEL "Endnotes:" TYPE DISPLAY FONT (NIL NIL MRR)) ((LABEL "Endnotes:" TYPE DISPLAY FONT (NIL NIL MRR))
(LABEL "Endnote" ID ENDNOTE SELECTEDFN TSP.FM.APPLY) (LABEL "Endnote" ID ENDNOTE SELECTEDFN TSP.FM.APPLY)
(LABEL "Insert Endnotes" ID INSERTNOTE SELECTEDFN TSP.FM.APPLY) (LABEL "Insert Endnotes" ID INSERTNOTE SELECTEDFN TSP.FM.APPLY)
@@ -150,7 +154,7 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
(LABEL "Create TOC" ID CREATETOC SELECTEDFN TSP.FM.APPLY) (LABEL "Create TOC" ID CREATETOC SELECTEDFN TSP.FM.APPLY)
(LABEL "View TOC" ID VIEWTOC SELECTEDFN TSP.FM.APPLY) (LABEL "View TOC" ID VIEWTOC SELECTEDFN TSP.FM.APPLY)
(LABEL "TOC Filename:" TYPE EDITSTART LINKS (EDIT TOC.FILE)) (LABEL "TOC Filename:" TYPE EDITSTART LINKS (EDIT TOC.FILE))
(LABEL "" TYPE EDIT ID TOC.FILE FONT (GACHA 10 MRR))) (LABEL "" TYPE EDIT ID TOC.FILE FONT (TERMINAL 10 MRR)))
((LABEL "Indices:" TYPE DISPLAY FONT (NIL NIL MRR)) ((LABEL "Indices:" TYPE DISPLAY FONT (NIL NIL MRR))
(LABEL "Index" ID INDEX SELECTEDFN TSP.FM.APPLY) (LABEL "Index" ID INDEX SELECTEDFN TSP.FM.APPLY)
(LABEL "Extended Index" ID XTNDINDEX SELECTEDFN TSP.FM.APPLY) (LABEL "Extended Index" ID XTNDINDEX SELECTEDFN TSP.FM.APPLY)
@@ -160,7 +164,7 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
(LABEL "Create Index" ID CREATEINDEX SELECTEDFN TSP.FM.APPLY) (LABEL "Create Index" ID CREATEINDEX SELECTEDFN TSP.FM.APPLY)
(LABEL "View Index" ID VIEWINDEX SELECTEDFN TSP.FM.APPLY) (LABEL "View Index" ID VIEWINDEX SELECTEDFN TSP.FM.APPLY)
(LABEL "Index Filename:" TYPE EDITSTART LINKS (EDIT INDEX.FILE)) (LABEL "Index Filename:" TYPE EDITSTART LINKS (EDIT INDEX.FILE))
(LABEL "" TYPE EDIT ID INDEX.FILE FONT (GACHA 10 MRR]) (LABEL "" TYPE EDIT ID INDEX.FILE FONT (TERMINAL 10 MRR])
(RPAQQ IMAGEOBJ.MENU.ITEMS (RPAQQ IMAGEOBJ.MENU.ITEMS
((UPDATE (UPDATE.ALL TSTREAM TWINDOW)) ((UPDATE (UPDATE.ALL TSTREAM TWINDOW))
@@ -430,14 +434,17 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
(LIST FAMILY SIZE (FONTPROP NEWENTRY.FONT 'FACE]) (LIST FAMILY SIZE (FONTPROP NEWENTRY.FONT 'FACE])
(GET.TSP.FONT.FAMILY (GET.TSP.FONT.FAMILY
[LAMBDA (DEFAULT.FONT) (* fsg " 8-Jul-87 15:44") [LAMBDA (DEFAULT.FONT) (* ; "Edited 24-Oct-2021 23:39 by rmk:")
(* * Get the font family from the menu or DEFAULT.FONT if the menu returns NIL.) (* fsg " 8-Jul-87 15:44")
(* * Get the font family from the menu or DEFAULT.FONT if the menu returns NIL.)
(OR [MKATOM (MENU (create MENU (OR [MKATOM (MENU (create MENU
TITLE _ "Font Family" TITLE _ "Font Family"
CENTERFLG _ T CENTERFLG _ T
ITEMS _ '((Classic 'CLASSIC) ITEMS _ '((Classic 'CLASSIC)
(Gacha 'GACHA) (Gacha 'GACHA)
(Terminal 'TERMINAL)
(Helvetica 'HELVETICA) (Helvetica 'HELVETICA)
(Modern 'MODERN) (Modern 'MODERN)
(TimesRoman 'TIMESROMAN] (TimesRoman 'TIMESROMAN]
@@ -468,10 +475,12 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
(FONTPROP DEFAULT.FONT 'FACE]) (FONTPROP DEFAULT.FONT 'FACE])
(ABBREVIATE.FONT (ABBREVIATE.FONT
[LAMBDA (FONT) (* fsg " 8-Jul-87 15:57") [LAMBDA (FONT) (* ; "Edited 24-Oct-2021 22:05 by rmk:")
(* * Returns an abbreviated font description. (* fsg " 8-Jul-87 15:57")
 For example, if the font is (TIMESROMAN 12
 (BOLD REGULAR REGULAR)) then the list (TimesRoman 12 Bold) is returned.) (* * Returns an abbreviated font description.
 For example, if the font is (TIMESROMAN 12
 (BOLD REGULAR REGULAR)) then the list (TimesRoman 12 Bold) is returned.)
(LET [(FONT.LIST (COND (LET [(FONT.LIST (COND
[(FONTP FONT) [(FONTP FONT)
@@ -482,13 +491,15 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
(LIST (LET ((FONT.FAMILY (CAR FONT.LIST))) (LIST (LET ((FONT.FAMILY (CAR FONT.LIST)))
(SELECTQ FONT.FAMILY (SELECTQ FONT.FAMILY
(CLASSIC 'Classic) (CLASSIC 'Classic)
(TERMINAL 'Terminal)
(GACHA 'Gacha) (GACHA 'Gacha)
(HELVETICA 'Helvetica) (HELVETICA 'Helvetica)
(MODERN 'Modern) (MODERN 'Modern)
(TIMESROMAN 'TimesRoman) (TIMESROMAN 'TimesRoman)
FONT.FAMILY)) FONT.FAMILY))
(CADR FONT.LIST) (CADR FONT.LIST)
(LET [(FONT.FACE (CONCATLIST (for FIELD in (CADDR FONT.LIST) collect (GNC FIELD] (LET [(FONT.FACE (CONCATLIST (for FIELD in (CADDR FONT.LIST)
collect (GNC FIELD]
(SELECTQ (MKATOM FONT.FACE) (SELECTQ (MKATOM FONT.FACE)
(MRR 'Standard) (MRR 'Standard)
(MIR 'Italic) (MIR 'Italic)
@@ -497,10 +508,10 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
FONT.FACE]) FONT.FACE])
(TMAX.SHADEOBJ (TMAX.SHADEOBJ
[LAMBDA (OBJ STREAM SHADE) (* ; "Edited 26-Jan-97 14:07 by rmk:") [LAMBDA (OBJ STREAM SHADE) (* ; "Edited 26-Jan-97 14:07 by rmk:")
(* fsg "17-Sep-87 11:25") (* fsg "17-Sep-87 11:25")
(* ;; "Shade the ImageObject to distinguish it from normal text.") (* ;; "Shade the ImageObject to distinguish it from normal text.")
(AND (IMAGESTREAMTYPEP STREAM 'DISPLAY) (AND (IMAGESTREAMTYPEP STREAM 'DISPLAY)
(LET [(BOUNDBOX (IMAGEOBJPROP OBJ 'BOUNDBOX] (LET [(BOUNDBOX (IMAGEOBJPROP OBJ 'BOUNDBOX]
@@ -543,74 +554,70 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
) )
(DECLARE%: EVAL@COMPILE (DECLARE%: EVAL@COMPILE
(PUTPROPS MAKE.DATEOBJ.IMAGEFNS MACRO (PUTPROPS MAKE.DATEOBJ.IMAGEFNS MACRO [LAMBDA NIL
[LAMBDA NIL (IMAGEFNSCREATE (FUNCTION DATE.DISPLAYFN)
(IMAGEFNSCREATE (FUNCTION DATE.DISPLAYFN) (FUNCTION DATE.IMAGEBOXFN)
(FUNCTION DATE.IMAGEBOXFN) (FUNCTION DATE.PUTFN)
(FUNCTION DATE.PUTFN) (FUNCTION DATE.GETFN)
(FUNCTION DATE.GETFN) (FUNCTION DATE.COPYFN)
(FUNCTION DATE.COPYFN) (FUNCTION DATE.BUTTONEVENTINFN)
(FUNCTION DATE.BUTTONEVENTINFN) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION NILL])
(FUNCTION NILL])
(PUTPROPS MAKE.NUMBEROBJ.IMAGEFNS MACRO (PUTPROPS MAKE.NUMBEROBJ.IMAGEFNS MACRO [LAMBDA NIL
[LAMBDA NIL (IMAGEFNSCREATE (FUNCTION NUMBER.DISPLAYFN)
(IMAGEFNSCREATE (FUNCTION NUMBER.DISPLAYFN) (FUNCTION NUMBER.IMAGEBOXFN)
(FUNCTION NUMBER.IMAGEBOXFN) (FUNCTION NUMBER.PUTFN)
(FUNCTION NUMBER.PUTFN) (FUNCTION NUMBER.GETFN)
(FUNCTION NUMBER.GETFN) (FUNCTION NUMBER.COPYFN)
(FUNCTION NUMBER.COPYFN) (FUNCTION NUMBER.BUTTONEVENTINFN)
(FUNCTION NUMBER.BUTTONEVENTINFN) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION XREF.WHENDELETEDFN)
(FUNCTION XREF.WHENDELETEDFN) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION NUMBER.PREPRINTFN])
(FUNCTION NUMBER.PREPRINTFN])
(PUTPROPS MAKE.REGMARKOBJ.IMAGEFNS MACRO (PUTPROPS MAKE.REGMARKOBJ.IMAGEFNS MACRO [LAMBDA NIL
[LAMBDA NIL (IMAGEFNSCREATE (FUNCTION REGMARK.DISPLAYFN)
(IMAGEFNSCREATE (FUNCTION REGMARK.DISPLAYFN) (FUNCTION REGMARK.IMAGEBOXFN)
(FUNCTION REGMARK.IMAGEBOXFN) (FUNCTION REGMARK.PUTFN)
(FUNCTION REGMARK.PUTFN) (FUNCTION REGMARK.GETFN)
(FUNCTION REGMARK.GETFN) (FUNCTION REGMARK.COPYFN)
(FUNCTION REGMARK.COPYFN) (FUNCTION REGMARK.BUTTONEVENTINFN)
(FUNCTION REGMARK.BUTTONEVENTINFN) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION NILL])
(FUNCTION NILL])
(PUTPROPS MAKE.XREFOBJ.IMAGEFNS MACRO (PUTPROPS MAKE.XREFOBJ.IMAGEFNS MACRO [LAMBDA NIL
[LAMBDA NIL (IMAGEFNSCREATE (FUNCTION XREF.DISPLAYFN)
(IMAGEFNSCREATE (FUNCTION XREF.DISPLAYFN) (FUNCTION XREF.IMAGEBOXFN)
(FUNCTION XREF.IMAGEBOXFN) (FUNCTION XREF.PUTFN)
(FUNCTION XREF.PUTFN) (FUNCTION XREF.GETFN)
(FUNCTION XREF.GETFN) (FUNCTION XREF.COPYFN)
(FUNCTION XREF.COPYFN) (FUNCTION XREF.BUTTONEVENTINFN)
(FUNCTION XREF.BUTTONEVENTINFN) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION NILL)
(FUNCTION NILL) (FUNCTION XREF.GET.DISPLAY.TEXT])
(FUNCTION XREF.GET.DISPLAY.TEXT])
) )
(RPAQ GP.DefaultFont (FONTCREATE 'GACHA 10)) (RPAQ GP.DefaultFont (FONTCREATE 'TERMINAL 10))
(RPAQQ GP.DefaultShade 10260) (RPAQQ GP.DefaultShade 1024)
(RPAQ \NUMBEROBJ.IMAGEFNS (MAKE.NUMBEROBJ.IMAGEFNS)) (RPAQ \NUMBEROBJ.IMAGEFNS (MAKE.NUMBEROBJ.IMAGEFNS))
@@ -643,14 +650,14 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
(TSP.FUNCTION.HOOKS) (TSP.FUNCTION.HOOKS)
(PUTPROPS TMAX COPYRIGHT ("Stanford University" 1987 1997 1999)) (PUTPROPS TMAX COPYRIGHT ("Stanford University" 1987 1997 1999))
(DECLARE%: DONTCOPY (DECLARE%: DONTCOPY
(FILEMAP (NIL (8744 15959 (TSP.DISPLAY.FMMENU 8754 . 9319) (TSP.SETUP.FILENAMES 9321 . 10572) ( (FILEMAP (NIL (8815 16030 (TSP.DISPLAY.FMMENU 8825 . 9390) (TSP.SETUP.FILENAMES 9392 . 10643) (
TSP.SETUP.FMMENU 10574 . 11034) (TSP.FMMENU 11036 . 12222) (TSP.FM.APPLY 12224 . 12543) (UPDATE.ALL TSP.SETUP.FMMENU 10645 . 11105) (TSP.FMMENU 11107 . 12293) (TSP.FM.APPLY 12295 . 12614) (UPDATE.ALL
12545 . 13217) (DOWNDATE.ALL 13219 . 13589) (TSP.FUNCTION.HOOKS 13591 . 15021) (TSP.GETFN 15023 . 12616 . 13288) (DOWNDATE.ALL 13290 . 13660) (TSP.FUNCTION.HOOKS 13662 . 15092) (TSP.GETFN 15094 .
15583) (TSP.PUTFN 15585 . 15957)) (16005 18254 (AutoUpdate.TOGGLE 16015 . 16251) (UPDATE? 16253 . 15654) (TSP.PUTFN 15656 . 16028)) (16076 18325 (AutoUpdate.TOGGLE 16086 . 16322) (UPDATE? 16324 .
16398) (NGROUP.Menu.TOGGLE 16400 . 16782) (NGROUPMENU.ENABLED? 16784 . 17020) ( 16469) (NGROUP.Menu.TOGGLE 16471 . 16853) (NGROUPMENU.ENABLED? 16855 . 17091) (
NGROUP.Text-Before.TOGGLE 17022 . 17272) (TEXTBEFORE.ENABLED? 17274 . 17437) (NGROUP.Text-After.TOGGLE NGROUP.Text-Before.TOGGLE 17093 . 17343) (TEXTBEFORE.ENABLED? 17345 . 17508) (NGROUP.Text-After.TOGGLE
17439 . 17687) (TEXTAFTER.ENABLED? 17689 . 17850) (Manual.Index.TOGGLE 17852 . 18091) ( 17510 . 17758) (TEXTAFTER.ENABLED? 17760 . 17921) (Manual.Index.TOGGLE 17923 . 18162) (
MANUALINDEX.ENABLED? 18093 . 18252)) (18288 23401 (GET.TSP.FONT 18298 . 19462) (GET.TSP.FONT.FAMILY MANUALINDEX.ENABLED? 18164 . 18323)) (18359 23832 (GET.TSP.FONT 18369 . 19533) (GET.TSP.FONT.FAMILY
19464 . 20147) (GET.TSP.FONT.SIZE 20149 . 20637) (GET.TSP.FONT.FACE 20639 . 21338) (ABBREVIATE.FONT 19535 . 20383) (GET.TSP.FONT.SIZE 20385 . 20873) (GET.TSP.FONT.FACE 20875 . 21574) (ABBREVIATE.FONT
21340 . 22649) (TMAX.SHADEOBJ 22651 . 23399)) (23441 24657 (TSP.LIST.OF.OBJECTS 23451 . 24655))))) 21576 . 23076) (TMAX.SHADEOBJ 23078 . 23830)) (23872 25088 (TSP.LIST.OF.OBJECTS 23882 . 25086)))))
STOP STOP

365
lispusers/TMAX-DATE
View File

@@ -1,39 +1,54 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(filecreated "12-Mar-88 15:42:46" {erinyes}<lispusers>lyric>tmax-date.\;2 15254
|changes| |to:| (fns current.display.font) (FILECREATED "24-Oct-2021 13:52:22" 
|{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>TMAX-DATE.;4| 14231
|previous| |date:| "30-Dec-87 11:39:18" {erinyes}<lispusers>lyric>tmax-date.\;1) |changes| |to:| (FNS FINDMONTH FINDTIME FINDHOUR AMPM CHANGE.DATE.FORMAT FINDYEAR)
(VARS TMAX-DATECOMS)
|previous| |date:| "12-Mar-88 15:42:46"
|{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>TMAX-DATE.;1|)
; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. ; Copyright (c) 1987-1988 by Xerox Corporation.
(prettycomprint tmax-datecoms) (PRETTYCOMPRINT TMAX-DATECOMS)
(rpaqq tmax-datecoms ((* |Developed| |under| |support| |from| nih |grant| rr-00785.) (RPAQQ TMAX-DATECOMS
(* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (
(* * tmax-datenil |ImageObject| |functions|) (* |;;| "Developed under support from NIH grant RR-00785. Written by Frank Gilmurray and Sami Shaio. Updated by Ron Kaplan (2021)")
(fns dateobj dateobjp date.displayfn date.imageboxfn date.putfn date.getfn
date.copyfn date.buttoneventinfn)
(* * |Date| |support| |functions|)
(fns current.display.font change.date.format) (* |;;;| "TMAX-DATE ImageObject functions")
(* * |Functions| |to| |change| |date| |format|)
(fns findtime findhour ampm findday nump findmonth findyear) (FNS DATEOBJ DATEOBJP DATE.DISPLAYFN DATE.IMAGEBOXFN DATE.PUTFN DATE.GETFN DATE.COPYFN
(vars date.format.items) DATE.BUTTONEVENTINFN)
(records daterecord)))
(* |;;;| "Date support functions")
(FNS CURRENT.DISPLAY.FONT CHANGE.DATE.FORMAT)
(* |;;;| "Functions to change date format")
(FNS FINDTIME FINDHOUR AMPM FINDDAY NUMP FINDMONTH FINDYEAR)
(VARS DATE.FORMAT.ITEMS)
(DECLARE\: DOEVAL@COMPILE DONTCOPY (RECORDS DATERECORD))))
(* |Developed| |under| |support| |from| nih |grant| rr-00785.) (* |;;|
"Developed under support from NIH grant RR-00785. Written by Frank Gilmurray and Sami Shaio. Updated by Ron Kaplan (2021)"
)
(* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|) (* |;;;| "TMAX-DATE ImageObject functions")
(* * tmax-datenil |ImageObject| |functions|) (DEFINEQ
(defineq
(dateobj (dateobj
(lambda (date/time date.string template) (* |fsg| "13-Jul-87 11:51") (lambda (date/time date.string template) (* |fsg| "13-Jul-87 11:51")
@@ -126,9 +141,12 @@
template.date))))) template.date)))))
'changed)))))) 'changed))))))
) )
(* * |Date| |support| |functions|)
(defineq
(* |;;;| "Date support functions")
(DEFINEQ
(current.display.font (current.display.font
(lambda (stream) (* \; "Edited 12-Mar-88 15:28 by drc:") (lambda (stream) (* \; "Edited 12-Mar-88 15:28 by drc:")
@@ -144,123 +162,103 @@
(|fetch| displayfd |of| current.font)) (|fetch| displayfd |of| current.font))
(t (shouldnt "Can't get current font")))))) (t (shouldnt "Can't get current font"))))))
(change.date.format (CHANGE.DATE.FORMAT
(lambda (date template) (* |ss:| "27-Jun-87 15:36") (LAMBDA (DATE TEMPLATE) (* \;
(* * |Convert| |the| |string| date |to| |the| |format| |specified| |by|  "Edited 24-Oct-2021 13:47 by rmk:")
 template.) (* |ss:| "27-Jun-87 15:36")
(cond (* |;;;| "Convert the string DATE to the format specified by TEMPLATE.")
(template (let ((version (|if| (equal (last template)
'(a)) (COND
|then| 'abbrev (TEMPLATE (LET ((VERSION (SELECTQ (CAR (LAST TEMPLATE))
|else| (|if| (equal (last template) (A 'ABBREV)
'(f)) (F 'FULL)
|then| 'full 'EURO))
|else| 'euro))) (FUNCLST '((D FINDDAY)
(funclst '((d findday) (M FINDMONTH)
(m findmonth) (Y FINDYEAR))))
(y findyear)))) (COND
(cond ((EQ T (CAR TEMPLATE))
((eq (car template) (FINDTIME DATE VERSION))
t) (T (LET ((CH (|if| (EQ VERSION 'ABBREV)
(findtime date version))
(t (let ((ch (|if| (eq version 'abbrev)
|then| "/" |then| "/"
|else| " "))) |else| " ")))
(concat (apply (cadr (assoc (car template) (CONCAT (APPLY (CADR (ASSOC (CAR TEMPLATE)
funclst)) FUNCLST))
(list date version)) (LIST DATE VERSION))
ch CH
(apply (cadr (assoc (cadr template) (APPLY (CADR (ASSOC (CADR TEMPLATE)
funclst)) FUNCLST))
(list date version)) (LIST DATE VERSION))
(|if| (equal ch " ") (|if| (EQUAL CH " ")
|then| ", " |then| ", "
|else| ch) |else| CH)
(apply (cadr (assoc (caddr template) (APPLY (CADR (ASSOC (CADDR TEMPLATE)
funclst)) FUNCLST))
(list date version)))))))) (LIST DATE VERSION))))))))
(t (date))))) (T (DATE)))))
) )
(* * |Functions| |to| |change| |date| |format|)
(defineq
(findtime
(lambda (olddate version) (* |ss:| "27-Jun-87 15:40")
(let ((hour (substring olddate 11 12))
(minutes (substring olddate 14 15)))
(|if| (equal version 'abbrev)
|then| (concat (findhour hour)
":" minutes " " (ampm hour))
|else| (|if| (equal version 'euro)
|then| (substring olddate 11 15)
|else| (concat (selectq (|if| (lessp (mkatom minutes)
46)
|then| (mkatom (findhour hour))
|else| (plus 1 (mkatom (findhour hour))))
(1 "one")
(2 "two")
(3 "three")
(4 "four")
(5 "five")
(6 "six")
(7 "seven")
(8 "eight")
(9 "nine")
(10 "ten")
(11 "eleven")
(12 "twelve")
nil)
" "
(|if| (and (greaterp (mkatom minutes)
15)
(lessp (mkatom minutes)
45))
|then| "thirty"
|else| "o'clock")
" "
(|if| (and (greaterp (mkatom minutes)
44)
(equal (findhour hour)
"11"))
|then| (|if| (equal (ampm hour)
"a.m.")
|then| "p.m."
|else| "a.m.")
|else| (ampm hour))))))))
(findhour (* |;;;| "Functions to change date format")
(lambda (hour) (* |ss:| " 8-Feb-86 17:49")
(cond
((lessp (mkatom hour)
13)
(cond
((lessp (mkatom hour)
10)
(mkstring (cadr (unpack hour))))
(t hour)))
(t (mkstring (selectq (mkatom hour)
(13 1)
(14 2)
(15 3)
(16 4)
(17 5)
(18 6)
(19 7)
(20 8)
(21 9)
(22 10)
(23 11)
(24 12)
nil))))))
(ampm (DEFINEQ
(lambda (hour)
(|if| (or (lessp (mkatom hour) (FINDTIME
12) (LAMBDA (OLDDATE VERSION) (* \;
(equal (mkatom hour)  "Edited 24-Oct-2021 13:28 by rmk:")
24))
(* |;;|
 "RMK: The spell-out default is very strange: it rounds the minutes to the nearest half hour.")
(* |;;| "RMK: Correct for Y2K: Substrings then work. Still, terrible code.")
(* |ss:| "27-Jun-87 15:40")
(LET* ((UDATE (\\UNPACKDATE (IDATE OLDDATE)))
(HOUR (CAR (NTH UDATE 4)))
(MINUTES (CAR (NTH UDATE 5))))
(SELECTQ VERSION
(ABBREV (CONCAT (FINDHOUR HOUR)
":" MINUTES " " (AMPM HOUR)))
(EURO (SUBSTRING OLDDATE 13 17))
(CONCAT (SELECTQ (|if| (LESSP MINUTES 46)
|then| (FINDHOUR HOUR)
|else| (PLUS 1 (FINDHOUR HOUR)))
(1 "one")
(2 "two")
(3 "three")
(4 "four")
(5 "five")
(6 "six")
(7 "seven")
(8 "eight")
(9 "nine")
(10 "ten")
(11 "eleven")
(12 "twelve")
NIL)
" "
(|if| (AND (GREATERP MINUTES 15)
(LESSP MINUTES 45))
|then| "thirty"
|else| "o'clock")
" "
(AMPM HOUR))))))
(FINDHOUR
(LAMBDA (HOUR) (* \;
 "Edited 24-Oct-2021 13:35 by rmk:")
(* |ss:| " 8-Feb-86 17:49")
(COND
((LESSP HOUR 13)
HOUR)
(T (IDIFFERENCE HOUR 12)))))
(AMPM
(LAMBDA (HOUR) (* \;
 "Edited 24-Oct-2021 13:37 by rmk:")
(|if| (OR (LESSP HOUR 12)
(EQ HOUR 24))
|then| "a.m." |then| "a.m."
|else| "p.m."))) |else| "p.m.")))
@@ -275,55 +273,66 @@
(* |changed|) (* |changed|)
(not (null (numberp (mkatom n)))))) (not (null (numberp (mkatom n))))))
(findmonth (FINDMONTH
(lambda (olddate version) (* |ss:| "27-Jun-87 15:40") (LAMBDA (OLDDATE VERSION) (* \;
(prog ((dates '((|Jan| 1 |January|)  "Edited 24-Oct-2021 13:52 by rmk:")
(|Feb| 2 |February|) (* |ss:| "27-Jun-87 15:40")
(|Mar| 3 |March|)
(|Apr| 4 |April|)
(|May| 5 |May|)
(|Jun| 6 |June|)
(|Jul| 7 |July|)
(|Aug| 8 |August|)
(|Sep| 9 |September|)
(|Oct| 10 |October|)
(|Nov| 11 |November|)
(|Dec| 12 |December|)))
(output nil))
(|if| (eq version 'abbrev)
|then| (setq output (car (cdr (assoc (mkatom (substring olddate 4 6))
dates))))
|else| (setq output (car (cddr (assoc (mkatom (substring olddate 4 6))
dates)))))
(return output))))
(findyear (* |;;| "\\UNPACKDATE uses 0 origin for months")
(lambda (olddate version) (* |ss:| "27-Jun-87 15:41")
(|if| (eq version 'abbrev) (LET ((MONTH (ASSOC (ADD1 (CAR (NTH (\\UNPACKDATE (IDATE OLDDATE))
|then| (mkatom (substring olddate 8 9)) 2)))
|else| (mkatom (concat "19" (substring olddate 8 9)))))) '((1 |Jan| |January|)
(2 |Feb| |February|)
(3 |Mar| |March|)
(4 |Apr| |April|)
(5 |May| |May|)
(6 |Jun| |June|)
(7 |Jul| |July|)
(8 |Aug| |August|)
(9 |Sep| |September|)
(10 |Oct| |October|)
(11 |Nov| |November|)
(12 |DecDecember|)))))
(|if| (EQ VERSION 'ABBREV)
|then| (CADR MONTH)
|else| (CADDR MONTH)))))
(FINDYEAR
(LAMBDA (OLDDATE VERSION) (* \;
 "Edited 24-Oct-2021 13:48 by rmk:")
(* |ss:| "27-Jun-87 15:41")
(CAR (\\UNPACKDATE (IDATE OLDDATE)))))
) )
(rpaqq date.format.items ((|Month Day, Year| '(m d y f) (RPAQQ DATE.FORMAT.ITEMS
"Insert current date as \"March 8, 1952\"") ((|Month Day, Year| '(M D Y F)
(|Month/Day/Year| '(m d y a) "Insert current date as \"3/8/52\"") "Insert current date as \"March 8, 1952\"")
(|Day Month, Year| '(d m y f) (|Month/Day/Year| '(M D Y A)
"Insert current date as \"8 March, 1952\"") "Insert current date as \"3/8/52\"")
(|Day/Month/Year| '(d m y a) "Insert current date as \"8/3/52\"") (|Day Month, Year| '(D M Y F)
(|Time| '(t f) "Insert current time as \"four thirty p.m.\"") "Insert current date as \"8 March, 1952\"")
(|Numbered Time| '(t a) "Insert current time as \"4:30 p.m.\"") (|Day/Month/Year| '(D M Y A)
(|Military Time| '(t e) "Insert current time as \"16:30\"") "Insert current date as \"8/3/52\"")
(|Update| t "Convert to current date/time"))) (|Time| '(T F)
(declare\: eval@compile "Insert current time as \"four thirty p.m.\"")
(|Numbered Time| '(T A)
"Insert current time as \"4:30 p.m.\"")
(|Military Time| '(T E)
"Insert current time as \"16:30\"")
(|Update| T "Convert to current date/time")))
(DECLARE\: DOEVAL@COMPILE DONTCOPY
(DECLARE\: EVAL@COMPILE
(record daterecord (datestring display.date template.date)) (RECORD DATERECORD (DATESTRING DISPLAY.DATE TEMPLATE.DATE))
) )
(putprops tmax-date copyright ("Xerox Corporation" 1987 1988)) )
(declare\: dontcopy (PUTPROPS TMAX-DATE COPYRIGHT ("Xerox Corporation" 1987 1988))
(filemap (nil (1398 6132 (dateobj 1408 . 2175) (dateobjp 2177 . 2611) (date.displayfn 2613 . 2935) ( (DECLARE\: DONTCOPY
date.imageboxfn 2937 . 3564) (date.putfn 3566 . 3764) (date.getfn 3766 . 4060) (date.copyfn 4062 . (FILEMAP (NIL (1422 6156 (DATEOBJ 1432 . 2199) (DATEOBJP 2201 . 2635) (DATE.DISPLAYFN 2637 . 2959) (
4594) (date.buttoneventinfn 4596 . 6130)) (6174 8957 (current.display.font 6184 . 6890) ( DATE.IMAGEBOXFN 2961 . 3588) (DATE.PUTFN 3590 . 3788) (DATE.GETFN 3790 . 4084) (DATE.COPYFN 4086 .
change.date.format 6892 . 8955)) (9012 14248 (findtime 9022 . 11531) (findhour 11533 . 12290) (ampm 4618) (DATE.BUTTONEVENTINFN 4620 . 6154)) (6200 8853 (CURRENT.DISPLAY.FONT 6210 . 6916) (
12292 . 12496) (findday 12498 . 12769) (nump 12771 . 13000) (findmonth 13002 . 13980) (findyear 13982 CHANGE.DATE.FORMAT 6918 . 8851)) (8906 13305 (FINDTIME 8916 . 10695) (FINDHOUR 10697 . 11058) (AMPM
. 14246))))) 11060 . 11359) (FINDDAY 11361 . 11632) (NUMP 11634 . 11863) (FINDMONTH 11865 . 12981) (FINDYEAR 12983
stop . 13303)))))
STOP

BIN
lispusers/TMAX-DATE.LCOM
View File

Binary file not shown.

BIN
lispusers/TMAX.LCOM
View File

Binary file not shown.

166
sources/ATBL
View File

@@ -1,10 +1,11 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "21-Aug-2021 08:06:49" {DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>ATBL.;22 91541
changes to%: (FNS \ORIGTERMTABLE) (FILECREATED "24-Oct-2021 21:53:59" {DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>ATBL.;28 92451
previous date%: "19-Aug-2021 14:45:21" changes to%: (FNS MAKE-READER-ENVIRONMENT)
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>ATBL.;21)
previous date%: "24-Oct-2021 20:14:01"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>ATBL.;27)
(* ; " (* ; "
@@ -14,15 +15,15 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
(PRETTYCOMPRINT ATBLCOMS) (PRETTYCOMPRINT ATBLCOMS)
(RPAQQ ATBLCOMS (RPAQQ ATBLCOMS
[(COMS (* ; [(COMS (* ;
 "Common features of read and terminal tables")  "Common features of read and terminal tables")
(DECLARE%: DONTCOPY (EXPORT (MACROS \SYNCODE \SETSYNCODE) (DECLARE%: DONTCOPY (EXPORT (MACROS \SYNCODE \SETSYNCODE)
(RECORDS CHARTABLE)) (RECORDS CHARTABLE))
(CONSTANTS \NSCHARHASHKEYS \NSCHARHASHOVERFLOW) (CONSTANTS \NSCHARHASHKEYS \NSCHARHASHOVERFLOW)
(MACROS \CREATENSCHARHASH)) (MACROS \CREATENSCHARHASH))
(FNS GETSYNTAX SETSYNTAX SYNTAXP \COPYSYNTAX \GETCHARCODE \SETFATSYNCODE \MAPCHARTABLE) (FNS GETSYNTAX SETSYNTAX SYNTAXP \COPYSYNTAX \GETCHARCODE \SETFATSYNCODE \MAPCHARTABLE)
) )
(COMS (* ; "terminal tables") (COMS (* ; "terminal tables")
(FNS CONTROL COPYTERMTABLE DELETECONTROL GETDELETECONTROL ECHOCHAR ECHOCONTROL ECHOMODE (FNS CONTROL COPYTERMTABLE DELETECONTROL GETDELETECONTROL ECHOCHAR ECHOCONTROL ECHOMODE
GETECHOMODE GETCONTROL GETTERMTABLE RAISE GETRAISE RESETTERMTABLE SETTERMTABLE GETECHOMODE GETCONTROL GETTERMTABLE RAISE GETRAISE RESETTERMTABLE SETTERMTABLE
TERMTABLEP \GETTERMSYNTAX \GTTERMTABLE \ORIGTERMTABLE \SETTERMSYNTAX TERMTABLEP \GETTERMSYNTAX \GTTERMTABLE \ORIGTERMTABLE \SETTERMSYNTAX
@@ -31,16 +32,16 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
(CONSTANTS * TERMCLASSES) (CONSTANTS * TERMCLASSES)
(RECORDS TERMCODE TERMTABLEP))) (RECORDS TERMCODE TERMTABLEP)))
(INITRECORDS TERMTABLEP)) (INITRECORDS TERMTABLEP))
(COMS (* ; "read tables") (COMS (* ; "read tables")
(FNS COPYREADTABLE FIND-READTABLE IN-READTABLE ESCAPE GETBRK GETREADTABLE GETSEPR (FNS COPYREADTABLE FIND-READTABLE IN-READTABLE ESCAPE GETBRK GETREADTABLE GETSEPR
READMACROS READTABLEP READTABLEPROP RESETREADTABLE SETBRK SETREADTABLE SETSEPR READMACROS READTABLEP READTABLEPROP RESETREADTABLE SETBRK SETREADTABLE SETSEPR
\GETREADSYNTAX \GTREADTABLE \GTREADTABLE1 \ORIGREADTABLE \READCLASSTOCODE \GETREADSYNTAX \GTREADTABLE \GTREADTABLE1 \ORIGREADTABLE \READCLASSTOCODE
\SETMACROSYNTAX \SETREADSYNTAX \READTABLEP.DEFPRINT) \SETMACROSYNTAX \SETREADSYNTAX \READTABLEP.DEFPRINT)
(PROP ARGNAMES READTABLEPROP) (PROP ARGNAMES READTABLEPROP)
(DECLARE%: EVAL@COMPILE DONTCOPY (* ; (DECLARE%: EVAL@COMPILE DONTCOPY (* ;
 "READCLASSTOKENS Generates READCLASSES and some interesting SELECTQ's")  "READCLASSTOKENS Generates READCLASSES and some interesting SELECTQ's")
(* ; (* ;
 "OTHER must be zero because of initialization.")  "OTHER must be zero because of initialization.")
[VARS READCLASSTOKENS (READCLASSES (MAPCAR READCLASSTOKENS [VARS READCLASSTOKENS (READCLASSES (MAPCAR READCLASSTOKENS
(FUNCTION (LAMBDA (FUNCTION (LAMBDA
(PAIR) (PAIR)
@@ -48,8 +49,8 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
".RC") ".RC")
(CADR PAIR] (CADR PAIR]
(MACROS \COMPUTED.FORM) (MACROS \COMPUTED.FORM)
(* ; (* ;
 "This macro ought to be official somehow")  "This macro ought to be official somehow")
(RECORDS CONTEXTS ESCAPES WAKEUPS) (RECORDS CONTEXTS ESCAPES WAKEUPS)
(EXPORT (MACROS \GETREADMACRODEF \GTREADTABLE \GTREADTABLE1) (EXPORT (MACROS \GETREADMACRODEF \GTREADTABLE \GTREADTABLE1)
(CONSTANTS MACROBIT BREAKBIT STOPATOMBIT ESCAPEBIT INNERESCAPEBIT) (CONSTANTS MACROBIT BREAKBIT STOPATOMBIT ESCAPEBIT INNERESCAPEBIT)
@@ -64,8 +65,8 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
[COMS (INITVARS (\READTABLEHASH)) [COMS (INITVARS (\READTABLEHASH))
(FNS \ATBLSET) (FNS \ATBLSET)
(INITRECORDS READER-ENVIRONMENT) (INITRECORDS READER-ENVIRONMENT)
(* ; (* ;
 "Definition is on CMLREAD, need it here to initialize *OLD-INTERLISP-READ-ENVIRONMENT*")  "Definition is on CMLREAD, need it here to initialize *OLD-INTERLISP-READ-ENVIRONMENT*")
(FNS MAKE-READER-ENVIRONMENT EQUAL-READER-ENVIRONMENT SET-READER-ENVIRONMENT) (FNS MAKE-READER-ENVIRONMENT EQUAL-READER-ENVIRONMENT SET-READER-ENVIRONMENT)
(INITVARS (*LISP-PACKAGE*) (INITVARS (*LISP-PACKAGE*)
(*INTERLISP-PACKAGE*) (*INTERLISP-PACKAGE*)
@@ -85,8 +86,8 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
(PUTPROPS \SYNCODE DMACRO [OPENLAMBDA (TABLE CHAR) (PUTPROPS \SYNCODE DMACRO [OPENLAMBDA (TABLE CHAR)
(CHECK (type? CHARTABLE TABLE)) (CHECK (type? CHARTABLE TABLE))
(* ; (* ;
 "0 is either NONE.TC, REAL.CCE, or OTHER.RC")  "0 is either NONE.TC, REAL.CCE, or OTHER.RC")
(COND (COND
((IGREATERP CHAR \MAXTHINCHAR) ((IGREATERP CHAR \MAXTHINCHAR)
(OR (AND (fetch (CHARTABLE NSCHARHASH) of TABLE) (OR (AND (fetch (CHARTABLE NSCHARHASH) of TABLE)
@@ -97,8 +98,8 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
(PUTPROPS \SETSYNCODE DMACRO [LAMBDA (TABLE CHAR CODE) (PUTPROPS \SETSYNCODE DMACRO [LAMBDA (TABLE CHAR CODE)
(CHECK (type? CHARTABLE TABLE)) (CHECK (type? CHARTABLE TABLE))
(* ; (* ;
 "0 is REAL.CCE, NONE.TC, OTHER.RC")  "0 is REAL.CCE, NONE.TC, OTHER.RC")
(COND (COND
((ILEQ CHAR \MAXTHINCHAR) ((ILEQ CHAR \MAXTHINCHAR)
(\PUTBASEBYTE TABLE CHAR CODE)) (\PUTBASEBYTE TABLE CHAR CODE))
@@ -401,8 +402,8 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
(DECLARE%: EVAL@COMPILE (DECLARE%: EVAL@COMPILE
(PUTPROPS \CREATENSCHARHASH MACRO (ARGS (* ; (PUTPROPS \CREATENSCHARHASH MACRO (ARGS (* ;
 "added size argument for creation of \ORIGTERMTABLE during initialization.")  "added size argument for creation of \ORIGTERMTABLE during initialization.")
(LIST 'HASHARRAY (OR (CAR ARGS) (LIST 'HASHARRAY (OR (CAR ARGS)
'\NSCHARHASHKEYS) '\NSCHARHASHKEYS)
'\NSCHARHASHOVERFLOW))) '\NSCHARHASHOVERFLOW)))
@@ -949,8 +950,8 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
(DECLARE%: EVAL@COMPILE (DECLARE%: EVAL@COMPILE
(ACCESSFNS TERMCODE ((CCECHO (LOGAND DATUM 24)) (ACCESSFNS TERMCODE ((CCECHO (LOGAND DATUM 24))
(TERMCLASS (LOGAND DATUM 7))) (* ; (TERMCLASS (LOGAND DATUM 7))) (* ;
 "We assume that values are appropriately shifted")  "We assume that values are appropriately shifted")
(CREATE (LOGOR CCECHO TERMCLASS))) (CREATE (LOGOR CCECHO TERMCLASS)))
(DATATYPE TERMTABLEP (TERMSA RAISEFLG DELCHARECHO LINEDELETE 1STCHDEL NTHCHDEL POSTCHDEL (DATATYPE TERMTABLEP (TERMSA RAISEFLG DELCHARECHO LINEDELETE 1STCHDEL NTHCHDEL POSTCHDEL
@@ -1640,34 +1641,34 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
(RECORD READMACRODEF (MACROTYPE . MACROFN)) (RECORD READMACRODEF (MACROTYPE . MACROFN))
(DATATYPE READTABLEP ((READSA POINTER) (* ; (DATATYPE READTABLEP ((READSA POINTER) (* ;
 "A CHARTABLE defining syntax of each char")  "A CHARTABLE defining syntax of each char")
(READMACRODEFS POINTER) (* ; (READMACRODEFS POINTER) (* ;
 "A hash table associating macro chars with macro definitions")  "A hash table associating macro chars with macro definitions")
(READMACROFLG FLAG) (* ; (READMACROFLG FLAG) (* ;
 "True if read macros are enabled (turned off by Interlisp's crufty READMACROS function)")  "True if read macros are enabled (turned off by Interlisp's crufty READMACROS function)")
(ESCAPEFLG FLAG) (* ; "True if the char(s) with escape syntax are enabled (turned off by Interlisp's crufty ESCAPE function)") (ESCAPEFLG FLAG) (* ; "True if the char(s) with escape syntax are enabled (turned off by Interlisp's crufty ESCAPE function)")
(COMMONLISP FLAG) (* ; (COMMONLISP FLAG) (* ;
 "True if table is a Common Lisp read table and hence must obey Common Lisp syntax rules")  "True if table is a Common Lisp read table and hence must obey Common Lisp syntax rules")
(NUMBERBASE BITS 5) (* ; "Not used") (NUMBERBASE BITS 5) (* ; "Not used")
(CASEINSENSITIVE FLAG) (* ; (CASEINSENSITIVE FLAG) (* ;
 "If true, unescaped lowercase chars are converted to uppercase in symbols")  "If true, unescaped lowercase chars are converted to uppercase in symbols")
(COMMONNUMSYNTAX FLAG) (* ; "True if number notation includes Common Lisp numbers: rationals as a/b, and the dfls exponent markers") (COMMONNUMSYNTAX FLAG) (* ; "True if number notation includes Common Lisp numbers: rationals as a/b, and the dfls exponent markers")
(USESILPACKAGE FLAG) (* ; (USESILPACKAGE FLAG) (* ;
 "If true, IL:READ ignores *PACKAGE* and reads in the IL package")  "If true, IL:READ ignores *PACKAGE* and reads in the IL package")
(NIL 5 FLAG) (NIL 5 FLAG)
(DISPATCHMACRODEFS POINTER) (* ; (DISPATCHMACRODEFS POINTER) (* ;
 "An a-list of dispatching macro char and its dispatch definitions")  "An a-list of dispatching macro char and its dispatch definitions")
(HASHMACROCHAR BYTE) (* ; (HASHMACROCHAR BYTE) (* ;
 "The character code used in this read table for the # dispatch macro")  "The character code used in this read table for the # dispatch macro")
(ESCAPECHAR BYTE) (* ; (ESCAPECHAR BYTE) (* ;
 "The character code used in this read table for single escape")  "The character code used in this read table for single escape")
(MULTESCAPECHAR BYTE) (* ; (MULTESCAPECHAR BYTE) (* ;
 "The character code used in this read table for multiple escape")  "The character code used in this read table for multiple escape")
(PACKAGECHAR BYTE) (* ; (PACKAGECHAR BYTE) (* ;
 "The character code used in this read table for package delimiter")  "The character code used in this read table for package delimiter")
(READTBLNAME POINTER) (* ; (READTBLNAME POINTER) (* ;
 "The canonical 'name' of this read table")  "The canonical 'name' of this read table")
) )
READSA _ (create CHARTABLE)) READSA _ (create CHARTABLE))
) )
@@ -1833,14 +1834,33 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
(DEFINEQ (DEFINEQ
(MAKE-READER-ENVIRONMENT (MAKE-READER-ENVIRONMENT
[LAMBDA (PACKAGE READTABLE BASE FORMAT PACKAGEFORM READTABLEFORM) [LAMBDA (PACKAGE READTABLE BASE FORMAT PACKAGEFORM READTABLEFORM)
(* ; "Edited 16-Aug-2021 23:44 by rmk:") (* ;
 "Edited 24-Oct-2021 21:53 by rmk:")
(* ;
 "Edited 16-Aug-2021 23:44 by rmk:")
(* ;; "PACKAGE can be a prop list of keyword-values")
(CL:WHEN (LISTP PACKAGE)
(CL:UNLESS READTABLE
(SETQ READTABLE (LISTGET PACKAGE :READTABLE)))
(CL:UNLESS BASE
(SETQ BASE (LISTGET PACKAGE :BASE)))
(CL:UNLESS FORMAT
(SETQ FORMAT (LISTGET PACKAGE :FORMAT)))
(SETQ PACKAGE (LISTGET PACKAGE :PACKAGE)))
(create READER-ENVIRONMENT (create READER-ENVIRONMENT
REPACKAGE _ (COND REPACKAGE _ (COND
(PACKAGE (\DTEST PACKAGE 'PACKAGE)) ((CL:PACKAGEP PACKAGE)
PACKAGE)
[PACKAGE (OR (CL:FIND-PACKAGE PACKAGE)
(\DEST PACKAGE 'PACKAGE]
(T *PACKAGE*)) (T *PACKAGE*))
REREADTABLE _ (COND REREADTABLE _ (COND
(READTABLE (\DTEST READTABLE 'READTABLEP)) ((READTABLEP READTABLE))
[READTABLE (OR (FIND-READTABLE READTABLE)
(\DEST READTABLE 'READTABLEP]
(T *READTABLE*)) (T *READTABLE*))
REBASE _ (COND REBASE _ (COND
(BASE (\CHECKRADIX BASE)) (BASE (\CHECKRADIX BASE))
@@ -1904,22 +1924,22 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
(PUTPROPS ATBL COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1990 1993 2018 (PUTPROPS ATBL COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1990 1993 2018
2021)) 2021))
(DECLARE%: DONTCOPY (DECLARE%: DONTCOPY
(FILEMAP (NIL (18036 29188 (GETSYNTAX 18046 . 22877) (SETSYNTAX 22879 . 23952) (SYNTAXP 23954 . 26451) (FILEMAP (NIL (18046 29198 (GETSYNTAX 18056 . 22887) (SETSYNTAX 22889 . 23962) (SYNTAXP 23964 . 26461)
(\COPYSYNTAX 26453 . 27170) (\GETCHARCODE 27172 . 27460) (\SETFATSYNCODE 27462 . 28753) ( (\COPYSYNTAX 26463 . 27180) (\GETCHARCODE 27182 . 27470) (\SETFATSYNCODE 27472 . 28763) (
\MAPCHARTABLE 28755 . 29186)) (29221 44187 (CONTROL 29231 . 29483) (COPYTERMTABLE 29485 . 29852) ( \MAPCHARTABLE 28765 . 29196)) (29231 44197 (CONTROL 29241 . 29493) (COPYTERMTABLE 29495 . 29862) (
DELETECONTROL 29854 . 32495) (GETDELETECONTROL 32497 . 33459) (ECHOCHAR 33461 . 34902) (ECHOCONTROL DELETECONTROL 29864 . 32505) (GETDELETECONTROL 32507 . 33469) (ECHOCHAR 33471 . 34912) (ECHOCONTROL
34904 . 35361) (ECHOMODE 35363 . 35609) (GETECHOMODE 35611 . 35775) (GETCONTROL 35777 . 35943) ( 34914 . 35371) (ECHOMODE 35373 . 35619) (GETECHOMODE 35621 . 35785) (GETCONTROL 35787 . 35953) (
GETTERMTABLE 35945 . 36012) (RAISE 36014 . 36440) (GETRAISE 36442 . 36604) (RESETTERMTABLE 36606 . GETTERMTABLE 35955 . 36022) (RAISE 36024 . 36450) (GETRAISE 36452 . 36614) (RESETTERMTABLE 36616 .
37690) (SETTERMTABLE 37692 . 37926) (TERMTABLEP 37928 . 38089) (\GETTERMSYNTAX 38091 . 38362) ( 37700) (SETTERMTABLE 37702 . 37936) (TERMTABLEP 37938 . 38099) (\GETTERMSYNTAX 38101 . 38372) (
\GTTERMTABLE 38364 . 38700) (\ORIGTERMTABLE 38702 . 42312) (\SETTERMSYNTAX 42314 . 42949) ( \GTTERMTABLE 38374 . 38710) (\ORIGTERMTABLE 38712 . 42322) (\SETTERMSYNTAX 42324 . 42959) (
\TERMCLASSTOCODE 42951 . 43380) (\TERMCODETOCLASS 43382 . 43769) (\LITCHECK 43771 . 44185)) (46717 \TERMCLASSTOCODE 42961 . 43390) (\TERMCODETOCLASS 43392 . 43779) (\LITCHECK 43781 . 44195)) (46727
70541 (COPYREADTABLE 46727 . 46925) (FIND-READTABLE 46927 . 47074) (IN-READTABLE 47076 . 47236) ( 70551 (COPYREADTABLE 46737 . 46935) (FIND-READTABLE 46937 . 47084) (IN-READTABLE 47086 . 47246) (
ESCAPE 47238 . 47491) (GETBRK 47493 . 47631) (GETREADTABLE 47633 . 47769) (GETSEPR 47771 . 47909) ( ESCAPE 47248 . 47501) (GETBRK 47503 . 47641) (GETREADTABLE 47643 . 47779) (GETSEPR 47781 . 47919) (
READMACROS 47911 . 48174) (READTABLEP 48176 . 48339) (READTABLEPROP 48341 . 53499) (RESETREADTABLE READMACROS 47921 . 48184) (READTABLEP 48186 . 48349) (READTABLEPROP 48351 . 53509) (RESETREADTABLE
53501 . 57748) (SETBRK 57750 . 59360) (SETREADTABLE 59362 . 59550) (SETSEPR 59552 . 61094) ( 53511 . 57758) (SETBRK 57760 . 59370) (SETREADTABLE 59372 . 59560) (SETSEPR 59562 . 61104) (
\GETREADSYNTAX 61096 . 63786) (\GTREADTABLE 63788 . 64013) (\GTREADTABLE1 64015 . 64271) ( \GETREADSYNTAX 61106 . 63796) (\GTREADTABLE 63798 . 64023) (\GTREADTABLE1 64025 . 64281) (
\ORIGREADTABLE 64273 . 66181) (\READCLASSTOCODE 66183 . 66634) (\SETMACROSYNTAX 66636 . 68431) ( \ORIGREADTABLE 64283 . 66191) (\READCLASSTOCODE 66193 . 66644) (\SETMACROSYNTAX 66646 . 68441) (
\SETREADSYNTAX 68433 . 69494) (\READTABLEP.DEFPRINT 69496 . 70539)) (83633 88086 (\ATBLSET 83643 . \SETREADSYNTAX 68443 . 69504) (\READTABLEP.DEFPRINT 69506 . 70549)) (83643 88096 (\ATBLSET 83653 .
88084)) (88533 91065 (MAKE-READER-ENVIRONMENT 88543 . 89321) (EQUAL-READER-ENVIRONMENT 89323 . 90467) 88094)) (88543 91975 (MAKE-READER-ENVIRONMENT 88553 . 90231) (EQUAL-READER-ENVIRONMENT 90233 . 91377)
(SET-READER-ENVIRONMENT 90469 . 91063))))) (SET-READER-ENVIRONMENT 91379 . 91973)))))
STOP STOP

BIN
sources/ATBL.LCOM
View File

Binary file not shown.

58
sources/IOCHAR
View File

@@ -1,14 +1,16 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "10-Aug-2020 21:44:38" {DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>IOCHAR.;5 90419
changes to%: (FNS FILEPOS FFILEPOS) (FILECREATED "24-Oct-2021 23:57:27" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>IOCHAR.;3 90360
previous date%: "11-Nov-2018 12:12:53" changes to%: (VARS IOCHARCOMS)
{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>IOCHAR.;4)
previous date%: "24-Oct-2021 23:53:23"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>IOCHAR.;2)
(* ; " (* ; "
Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 2018, 2020 by Venue & Xerox Corporation. All rights reserved. Copyright (c) 1981-1988, 1990-1991, 2018, 2020 by Venue & Xerox Corporation.
") ")
(PRETTYCOMPRINT IOCHARCOMS) (PRETTYCOMPRINT IOCHARCOMS)
@@ -38,17 +40,17 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 2018,
(\MIN.SEARCH.LENGTH 100))) (\MIN.SEARCH.LENGTH 100)))
(INITRESOURCES \FFDELTA1 \FFDELTA2 \FFPATCHAR)) (INITRESOURCES \FFDELTA1 \FFDELTA2 \FFPATCHAR))
[COMS [COMS
(* ;; "DATE Functions") (* ;; "DATE Functions")
(FNS DATE DATEFORMAT GDATE IDATE \IDATESCANTOKEN \IDATE-PARSE-MONTH \OUTDATE (FNS DATE DATEFORMAT GDATE IDATE \IDATESCANTOKEN \IDATE-PARSE-MONTH \OUTDATE
\OUTDATE-STRING \RPLRIGHT \UNPACKDATE \PACKDATE \DTSCAN \ISDST? \CHECKDSTCHANGE) \OUTDATE-STRING \RPLRIGHT \UNPACKDATE \PACKDATE \DTSCAN \ISDST? \CHECKDSTCHANGE)
(OPTIMIZERS DATEFORMAT) (OPTIMIZERS DATEFORMAT)
(* ;; "Because DST begins the FIRST weekend in April now, \BeginDST changed from 120 to 98 as of 4/3/87 (JDS) Note: this only affects standalone users--those with time servers automatically get correct local info (bvm)") (* ;; "Because DST begins the FIRST weekend in April now, \BeginDST changed from 120 to 98 as of 4/3/87 (JDS) Note: this only affects standalone users--those with time servers automatically get correct local info (bvm)")
(INITVARS (\TimeZoneComp 8) (INITVARS (\TimeZoneComp 8)
(\BeginDST 98) (\BeginDST 74)
(\EndDST 304) (\EndDST 312)
(\DayLightSavings T)) (\DayLightSavings T))
(ADDVARS (TIME.ZONES (8 "PST" "PDT") (ADDVARS (TIME.ZONES (8 "PST" "PDT")
(7 "MST" "MDT") (7 "MST" "MDT")
@@ -163,14 +165,14 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 2018,
(CL:DEFUN XCL:PACK (NAMES &OPTIONAL (PACKAGE *PACKAGE*)) (CL:DEFUN XCL:PACK (NAMES &OPTIONAL (PACKAGE *PACKAGE*))
(* ;;; "NAMES should be a list of symbols and strings. A new symbol is created in the given package with a print name equal to the concatenation of the of the NAMES. ") (* ;;; "NAMES should be a list of symbols and strings. A new symbol is created in the given package with a print name equal to the concatenation of the of the NAMES. ")
(CL:INTERN (CONCATLIST NAMES) (CL:INTERN (CONCATLIST NAMES)
PACKAGE)) PACKAGE))
(CL:DEFUN XCL:PACK* (&REST NAMES) (CL:DEFUN XCL:PACK* (&REST NAMES)
(* ;;; "NAMES should be a list of symbols and strings. A new symbol is created in the current package with a print name equal to the concatenation of the of the NAMES. ") (* ;;; "NAMES should be a list of symbols and strings. A new symbol is created in the current package with a print name equal to the concatenation of the of the NAMES. ")
(CL:INTERN (CONCATLIST NAMES))) (CL:INTERN (CONCATLIST NAMES)))
(DECLARE%: DOEVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY
@@ -182,11 +184,11 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 2018,
(PUTPROPS \CATRANSLATE MACRO (OPENLAMBDA (CABASE CASIZE CAFAT CHAR) (PUTPROPS \CATRANSLATE MACRO (OPENLAMBDA (CABASE CASIZE CAFAT CHAR)
(COND (COND
((ILEQ CHAR CASIZE)(* ; ((ILEQ CHAR CASIZE)(* ;
 "If it's in the table, use the table value")  "If it's in the table, use the table value")
(\GETBASEBYTE CABASE CHAR)) (\GETBASEBYTE CABASE CHAR))
(T (* ; (T (* ;
 "Off the end -- assume it's itself")  "Off the end -- assume it's itself")
CHAR)))) CHAR))))
) )
) )
@@ -1326,9 +1328,9 @@ DONTCOPY
(RPAQ? \TimeZoneComp 8) (RPAQ? \TimeZoneComp 8)
(RPAQ? \BeginDST 98) (RPAQ? \BeginDST 74)
(RPAQ? \EndDST 304) (RPAQ? \EndDST 312)
(RPAQ? \DayLightSavings T) (RPAQ? \DayLightSavings T)
@@ -1372,15 +1374,15 @@ DONTCOPY
(PUTPROPS IOCHAR COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990 (PUTPROPS IOCHAR COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990
1991 2018 2020)) 1991 2018 2020))
(DECLARE%: DONTCOPY (DECLARE%: DONTCOPY
(FILEMAP (NIL (3507 7301 (CHCON 3517 . 4367) (UNPACK 4369 . 5263) (DCHCON 5265 . 6532) (DUNPACK 6534 (FILEMAP (NIL (3448 7242 (CHCON 3458 . 4308) (UNPACK 4310 . 5204) (DCHCON 5206 . 6473) (DUNPACK 6475
. 7299)) (7302 18817 (UALPHORDER 7312 . 7408) (ALPHORDER 7410 . 9213) (CONCAT 9215 . 9860) ( . 7240)) (7243 18758 (UALPHORDER 7253 . 7349) (ALPHORDER 7351 . 9154) (CONCAT 9156 . 9801) (
CONCATCODES 9862 . 10048) (PACKC 10050 . 12653) (PACK 12655 . 13234) (PACK* 13236 . 14958) (\PACK.ITEM CONCATCODES 9803 . 9989) (PACKC 9991 . 12594) (PACK 12596 . 13175) (PACK* 13177 . 14899) (\PACK.ITEM
14960 . 15415) (STRPOS 15417 . 18815)) (18819 19108 (XCL:PACK 18819 . 19108)) (19110 19360 (XCL:PACK* 14901 . 15356) (STRPOS 15358 . 18756)) (18760 19049 (XCL:PACK 18760 . 19049)) (19051 19301 (XCL:PACK*
19110 . 19360)) (20078 22469 (STRPOSL 20088 . 21714) (MAKEBITTABLE 21716 . 22467)) (22631 23108 ( 19051 . 19301)) (20019 22410 (STRPOSL 20029 . 21655) (MAKEBITTABLE 21657 . 22408)) (22572 23049 (
CASEARRAY 22641 . 22831) (UPPERCASEARRAY 22833 . 23106)) (23430 47032 (FILEPOS 23440 . 33352) ( CASEARRAY 22582 . 22772) (UPPERCASEARRAY 22774 . 23047)) (23371 46973 (FILEPOS 23381 . 33293) (
FFILEPOS 33354 . 44467) (\SETUP.FFILEPOS 44469 . 47030)) (47820 89067 (DATE 47830 . 47916) (DATEFORMAT FFILEPOS 33295 . 44408) (\SETUP.FFILEPOS 44410 . 46971)) (47761 89008 (DATE 47771 . 47857) (DATEFORMAT
47918 . 48010) (GDATE 48012 . 48123) (IDATE 48125 . 59796) (\IDATESCANTOKEN 59798 . 61077) ( 47859 . 47951) (GDATE 47953 . 48064) (IDATE 48066 . 59737) (\IDATESCANTOKEN 59739 . 61018) (
\IDATE-PARSE-MONTH 61079 . 64775) (\OUTDATE 64777 . 77525) (\OUTDATE-STRING 77527 . 78142) (\RPLRIGHT \IDATE-PARSE-MONTH 61020 . 64716) (\OUTDATE 64718 . 77466) (\OUTDATE-STRING 77468 . 78083) (\RPLRIGHT
78144 . 78382) (\UNPACKDATE 78384 . 84175) (\PACKDATE 84177 . 87497) (\DTSCAN 87499 . 87641) (\ISDST? 78085 . 78323) (\UNPACKDATE 78325 . 84116) (\PACKDATE 84118 . 87438) (\DTSCAN 87440 . 87582) (\ISDST?
87643 . 88150) (\CHECKDSTCHANGE 88152 . 89065))))) 87584 . 88091) (\CHECKDSTCHANGE 88093 . 89006)))))
STOP STOP

BIN
sources/IOCHAR.LCOM
View File

Binary file not shown.