github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-01-12 00:42:56 +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
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
10 changed files with 557 additions and 547 deletions
Show Stats 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.

207
lispusers/TMAX
View File

@ -1,22 +1,26 @@
(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)
(RPAQQ TMAXCOMS
( (* ;
 "Developed under support from NIH grant RR-00785.")
(* ;
 "Written by Frank Gilmurray and Sami Shaio.")
( (* ;
 "Developed under support from NIH grant RR-00785.")
(* ;
 "Written by Frank Gilmurray and Sami Shaio.")
(FILES (COMPILED SYSLOAD)
TEDIT FREEMENU)
(VARS TMAX.FILE.LIST)
@ -27,38 +31,38 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
(P (DOFILESLOAD TMAX.FILE.LIST))
(* ;;; "Free Menu data structures")
(* ;;; "Free Menu data structures")
(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
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?
NGROUP.Text-Before.TOGGLE TEXTBEFORE.ENABLED? NGROUP.Text-After.TOGGLE
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
TMAX.SHADEOBJ)
(* ;;; "Collect ImageObjects")
(* ;;; "Collect ImageObjects")
(FNS TSP.LIST.OF.OBJECTS)
(GLOBALVARS GP.DefaultFont GP.DefaultShade)
(MACROS MAKE.DATEOBJ.IMAGEFNS MAKE.NUMBEROBJ.IMAGEFNS MAKE.REGMARKOBJ.IMAGEFNS
MAKE.XREFOBJ.IMAGEFNS)
(VARS (GP.DefaultFont (FONTCREATE 'GACHA 10))
(GP.DefaultShade 10260)
(VARS (GP.DefaultFont (FONTCREATE 'TERMINAL 10))
(GP.DefaultShade 1024)
(\NUMBEROBJ.IMAGEFNS (MAKE.NUMBEROBJ.IMAGEFNS))
(\DATEOBJ.IMAGEFNS (MAKE.DATEOBJ.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 "Reference By" TYPE STATE MENUITEMS (Ask Value Page)
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 "Endnote" ID ENDNOTE 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 "View TOC" ID VIEWTOC SELECTEDFN TSP.FM.APPLY)
(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 "Index" ID INDEX 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 "View Index" ID VIEWINDEX SELECTEDFN TSP.FM.APPLY)
(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
((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])
(GET.TSP.FONT.FAMILY
[LAMBDA (DEFAULT.FONT) (* fsg " 8-Jul-87 15:44")
(* * Get the font family from the menu or DEFAULT.FONT if the menu returns NIL.)
[LAMBDA (DEFAULT.FONT) (* ; "Edited 24-Oct-2021 23:39 by rmk:")
(* 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
TITLE _ "Font Family"
CENTERFLG _ T
ITEMS _ '((Classic 'CLASSIC)
(Gacha 'GACHA)
(Terminal 'TERMINAL)
(Helvetica 'HELVETICA)
(Modern 'MODERN)
(TimesRoman 'TIMESROMAN]
@ -468,10 +475,12 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
(FONTPROP DEFAULT.FONT 'FACE])
(ABBREVIATE.FONT
[LAMBDA (FONT) (* fsg " 8-Jul-87 15:57")
(* * Returns an abbreviated font description.
 For example, if the font is (TIMESROMAN 12
 (BOLD REGULAR REGULAR)) then the list (TimesRoman 12 Bold) is returned.)
[LAMBDA (FONT) (* ; "Edited 24-Oct-2021 22:05 by rmk:")
(* fsg " 8-Jul-87 15:57")
(* * 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
[(FONTP FONT)
@ -482,13 +491,15 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
(LIST (LET ((FONT.FAMILY (CAR FONT.LIST)))
(SELECTQ FONT.FAMILY
(CLASSIC 'Classic)
(TERMINAL 'Terminal)
(GACHA 'Gacha)
(HELVETICA 'Helvetica)
(MODERN 'Modern)
(TIMESROMAN 'TimesRoman)
FONT.FAMILY))
(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)
(MRR 'Standard)
(MIR 'Italic)
@ -497,10 +508,10 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
FONT.FACE])
(TMAX.SHADEOBJ
[LAMBDA (OBJ STREAM SHADE) (* ; "Edited 26-Jan-97 14:07 by rmk:")
(* fsg "17-Sep-87 11:25")
[LAMBDA (OBJ STREAM SHADE) (* ; "Edited 26-Jan-97 14:07 by rmk:")
(* 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)
(LET [(BOUNDBOX (IMAGEOBJPROP OBJ 'BOUNDBOX]
@ -543,74 +554,70 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
)
(DECLARE%: EVAL@COMPILE
(PUTPROPS MAKE.DATEOBJ.IMAGEFNS MACRO
[LAMBDA NIL
(IMAGEFNSCREATE (FUNCTION DATE.DISPLAYFN)
(FUNCTION DATE.IMAGEBOXFN)
(FUNCTION DATE.PUTFN)
(FUNCTION DATE.GETFN)
(FUNCTION DATE.COPYFN)
(FUNCTION DATE.BUTTONEVENTINFN)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL])
(PUTPROPS MAKE.DATEOBJ.IMAGEFNS MACRO [LAMBDA NIL
(IMAGEFNSCREATE (FUNCTION DATE.DISPLAYFN)
(FUNCTION DATE.IMAGEBOXFN)
(FUNCTION DATE.PUTFN)
(FUNCTION DATE.GETFN)
(FUNCTION DATE.COPYFN)
(FUNCTION DATE.BUTTONEVENTINFN)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL])
(PUTPROPS MAKE.NUMBEROBJ.IMAGEFNS MACRO
[LAMBDA NIL
(IMAGEFNSCREATE (FUNCTION NUMBER.DISPLAYFN)
(FUNCTION NUMBER.IMAGEBOXFN)
(FUNCTION NUMBER.PUTFN)
(FUNCTION NUMBER.GETFN)
(FUNCTION NUMBER.COPYFN)
(FUNCTION NUMBER.BUTTONEVENTINFN)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION XREF.WHENDELETEDFN)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NUMBER.PREPRINTFN])
(PUTPROPS MAKE.NUMBEROBJ.IMAGEFNS MACRO [LAMBDA NIL
(IMAGEFNSCREATE (FUNCTION NUMBER.DISPLAYFN)
(FUNCTION NUMBER.IMAGEBOXFN)
(FUNCTION NUMBER.PUTFN)
(FUNCTION NUMBER.GETFN)
(FUNCTION NUMBER.COPYFN)
(FUNCTION NUMBER.BUTTONEVENTINFN)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION XREF.WHENDELETEDFN)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NUMBER.PREPRINTFN])
(PUTPROPS MAKE.REGMARKOBJ.IMAGEFNS MACRO
[LAMBDA NIL
(IMAGEFNSCREATE (FUNCTION REGMARK.DISPLAYFN)
(FUNCTION REGMARK.IMAGEBOXFN)
(FUNCTION REGMARK.PUTFN)
(FUNCTION REGMARK.GETFN)
(FUNCTION REGMARK.COPYFN)
(FUNCTION REGMARK.BUTTONEVENTINFN)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL])
(PUTPROPS MAKE.REGMARKOBJ.IMAGEFNS MACRO [LAMBDA NIL
(IMAGEFNSCREATE (FUNCTION REGMARK.DISPLAYFN)
(FUNCTION REGMARK.IMAGEBOXFN)
(FUNCTION REGMARK.PUTFN)
(FUNCTION REGMARK.GETFN)
(FUNCTION REGMARK.COPYFN)
(FUNCTION REGMARK.BUTTONEVENTINFN)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL])
(PUTPROPS MAKE.XREFOBJ.IMAGEFNS MACRO
[LAMBDA NIL
(IMAGEFNSCREATE (FUNCTION XREF.DISPLAYFN)
(FUNCTION XREF.IMAGEBOXFN)
(FUNCTION XREF.PUTFN)
(FUNCTION XREF.GETFN)
(FUNCTION XREF.COPYFN)
(FUNCTION XREF.BUTTONEVENTINFN)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION XREF.GET.DISPLAY.TEXT])
(PUTPROPS MAKE.XREFOBJ.IMAGEFNS MACRO [LAMBDA NIL
(IMAGEFNSCREATE (FUNCTION XREF.DISPLAYFN)
(FUNCTION XREF.IMAGEBOXFN)
(FUNCTION XREF.PUTFN)
(FUNCTION XREF.GETFN)
(FUNCTION XREF.COPYFN)
(FUNCTION XREF.BUTTONEVENTINFN)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(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))
@ -643,14 +650,14 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
(TSP.FUNCTION.HOOKS)
(PUTPROPS TMAX COPYRIGHT ("Stanford University" 1987 1997 1999))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (8744 15959 (TSP.DISPLAY.FMMENU 8754 . 9319) (TSP.SETUP.FILENAMES 9321 . 10572) (
TSP.SETUP.FMMENU 10574 . 11034) (TSP.FMMENU 11036 . 12222) (TSP.FM.APPLY 12224 . 12543) (UPDATE.ALL
12545 . 13217) (DOWNDATE.ALL 13219 . 13589) (TSP.FUNCTION.HOOKS 13591 . 15021) (TSP.GETFN 15023 .
15583) (TSP.PUTFN 15585 . 15957)) (16005 18254 (AutoUpdate.TOGGLE 16015 . 16251) (UPDATE? 16253 .
16398) (NGROUP.Menu.TOGGLE 16400 . 16782) (NGROUPMENU.ENABLED? 16784 . 17020) (
NGROUP.Text-Before.TOGGLE 17022 . 17272) (TEXTBEFORE.ENABLED? 17274 . 17437) (NGROUP.Text-After.TOGGLE
17439 . 17687) (TEXTAFTER.ENABLED? 17689 . 17850) (Manual.Index.TOGGLE 17852 . 18091) (
MANUALINDEX.ENABLED? 18093 . 18252)) (18288 23401 (GET.TSP.FONT 18298 . 19462) (GET.TSP.FONT.FAMILY
19464 . 20147) (GET.TSP.FONT.SIZE 20149 . 20637) (GET.TSP.FONT.FACE 20639 . 21338) (ABBREVIATE.FONT
21340 . 22649) (TMAX.SHADEOBJ 22651 . 23399)) (23441 24657 (TSP.LIST.OF.OBJECTS 23451 . 24655)))))
(FILEMAP (NIL (8815 16030 (TSP.DISPLAY.FMMENU 8825 . 9390) (TSP.SETUP.FILENAMES 9392 . 10643) (
TSP.SETUP.FMMENU 10645 . 11105) (TSP.FMMENU 11107 . 12293) (TSP.FM.APPLY 12295 . 12614) (UPDATE.ALL
12616 . 13288) (DOWNDATE.ALL 13290 . 13660) (TSP.FUNCTION.HOOKS 13662 . 15092) (TSP.GETFN 15094 .
15654) (TSP.PUTFN 15656 . 16028)) (16076 18325 (AutoUpdate.TOGGLE 16086 . 16322) (UPDATE? 16324 .
16469) (NGROUP.Menu.TOGGLE 16471 . 16853) (NGROUPMENU.ENABLED? 16855 . 17091) (
NGROUP.Text-Before.TOGGLE 17093 . 17343) (TEXTBEFORE.ENABLED? 17345 . 17508) (NGROUP.Text-After.TOGGLE
17510 . 17758) (TEXTAFTER.ENABLED? 17760 . 17921) (Manual.Index.TOGGLE 17923 . 18162) (
MANUALINDEX.ENABLED? 18164 . 18323)) (18359 23832 (GET.TSP.FONT 18369 . 19533) (GET.TSP.FONT.FAMILY
19535 . 20383) (GET.TSP.FONT.SIZE 20385 . 20873) (GET.TSP.FONT.FACE 20875 . 21574) (ABBREVIATE.FONT
21576 . 23076) (TMAX.SHADEOBJ 23078 . 23830)) (23872 25088 (TSP.LIST.OF.OBJECTS 23882 . 25086)))))
STOP

365
lispusers/TMAX-DATE
View File

@ -1,39 +1,54 @@
(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.)
(* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|)
(* * tmax-datenil |ImageObject| |functions|)
(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)
(* * |Functions| |to| |change| |date| |format|)
(fns findtime findhour ampm findday nump findmonth findyear)
(vars date.format.items)
(records daterecord)))
(RPAQQ TMAX-DATECOMS
(
(* |;;| "Developed under support from NIH grant RR-00785. Written by Frank Gilmurray and Sami Shaio. Updated by Ron Kaplan (2021)")
(* |;;;| "TMAX-DATE ImageObject functions")
(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)
(* |;;;| "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
(lambda (date/time date.string template) (* |fsg| "13-Jul-87 11:51")
@ -126,9 +141,12 @@
template.date)))))
'changed))))))
)
(* * |Date| |support| |functions|)
(defineq
(* |;;;| "Date support functions")
(DEFINEQ
(current.display.font
(lambda (stream) (* \; "Edited 12-Mar-88 15:28 by drc:")
@ -144,123 +162,103 @@
(|fetch| displayfd |of| current.font))
(t (shouldnt "Can't get current font"))))))
(change.date.format
(lambda (date template) (* |ss:| "27-Jun-87 15:36")
(* * |Convert| |the| |string| date |to| |the| |format| |specified| |by|
 template.)
(CHANGE.DATE.FORMAT
(LAMBDA (DATE TEMPLATE) (* \;
 "Edited 24-Oct-2021 13:47 by rmk:")
(* |ss:| "27-Jun-87 15:36")
(cond
(template (let ((version (|if| (equal (last template)
'(a))
|then| 'abbrev
|else| (|if| (equal (last template)
'(f))
|then| 'full
|else| 'euro)))
(funclst '((d findday)
(m findmonth)
(y findyear))))
(cond
((eq (car template)
t)
(findtime date version))
(t (let ((ch (|if| (eq version 'abbrev)
(* |;;;| "Convert the string DATE to the format specified by TEMPLATE.")
(COND
(TEMPLATE (LET ((VERSION (SELECTQ (CAR (LAST TEMPLATE))
(A 'ABBREV)
(F 'FULL)
'EURO))
(FUNCLST '((D FINDDAY)
(M FINDMONTH)
(Y FINDYEAR))))
(COND
((EQ T (CAR TEMPLATE))
(FINDTIME DATE VERSION))
(T (LET ((CH (|if| (EQ VERSION 'ABBREV)
|then| "/"
|else| " ")))
(concat (apply (cadr (assoc (car template)
funclst))
(list date version))
ch
(apply (cadr (assoc (cadr template)
funclst))
(list date version))
(|if| (equal ch " ")
(CONCAT (APPLY (CADR (ASSOC (CAR TEMPLATE)
FUNCLST))
(LIST DATE VERSION))
CH
(APPLY (CADR (ASSOC (CADR TEMPLATE)
FUNCLST))
(LIST DATE VERSION))
(|if| (EQUAL CH " ")
|then| ", "
|else| ch)
(apply (cadr (assoc (caddr template)
funclst))
(list date version))))))))
(t (date)))))
|else| CH)
(APPLY (CADR (ASSOC (CADDR TEMPLATE)
FUNCLST))
(LIST DATE VERSION))))))))
(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
(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))))))
(* |;;;| "Functions to change date format")
(ampm
(lambda (hour)
(|if| (or (lessp (mkatom hour)
12)
(equal (mkatom hour)
24))
(DEFINEQ
(FINDTIME
(LAMBDA (OLDDATE VERSION) (* \;
 "Edited 24-Oct-2021 13:28 by rmk:")
(* |;;|
 "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."
|else| "p.m.")))
@ -275,55 +273,66 @@
(* |changed|)
(not (null (numberp (mkatom n))))))
(findmonth
(lambda (olddate version) (* |ss:| "27-Jun-87 15:40")
(prog ((dates '((|Jan| 1 |January|)
(|Feb| 2 |February|)
(|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))))
(FINDMONTH
(LAMBDA (OLDDATE VERSION) (* \;
 "Edited 24-Oct-2021 13:52 by rmk:")
(* |ss:| "27-Jun-87 15:40")
(findyear
(lambda (olddate version) (* |ss:| "27-Jun-87 15:41")
(|if| (eq version 'abbrev)
|then| (mkatom (substring olddate 8 9))
|else| (mkatom (concat "19" (substring olddate 8 9))))))
(* |;;| "\\UNPACKDATE uses 0 origin for months")
(LET ((MONTH (ASSOC (ADD1 (CAR (NTH (\\UNPACKDATE (IDATE OLDDATE))
2)))
'((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)
"Insert current date as \"March 8, 1952\"")
(|Month/Day/Year| '(m d y a) "Insert current date as \"3/8/52\"")
(|Day Month, Year| '(d m y f)
"Insert current date as \"8 March, 1952\"")
(|Day/Month/Year| '(d m y a) "Insert current date as \"8/3/52\"")
(|Time| '(t f) "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\: eval@compile
(RPAQQ DATE.FORMAT.ITEMS
((|Month Day, Year| '(M D Y F)
"Insert current date as \"March 8, 1952\"")
(|Month/Day/Year| '(M D Y A)
"Insert current date as \"3/8/52\"")
(|Day Month, Year| '(D M Y F)
"Insert current date as \"8 March, 1952\"")
(|Day/Month/Year| '(D M Y A)
"Insert current date as \"8/3/52\"")
(|Time| '(T F)
"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
(filemap (nil (1398 6132 (dateobj 1408 . 2175) (dateobjp 2177 . 2611) (date.displayfn 2613 . 2935) (
date.imageboxfn 2937 . 3564) (date.putfn 3566 . 3764) (date.getfn 3766 . 4060) (date.copyfn 4062 .
4594) (date.buttoneventinfn 4596 . 6130)) (6174 8957 (current.display.font 6184 . 6890) (
change.date.format 6892 . 8955)) (9012 14248 (findtime 9022 . 11531) (findhour 11533 . 12290) (ampm
12292 . 12496) (findday 12498 . 12769) (nump 12771 . 13000) (findmonth 13002 . 13980) (findyear 13982
. 14246)))))
stop
)
(PUTPROPS TMAX-DATE COPYRIGHT ("Xerox Corporation" 1987 1988))
(DECLARE\: DONTCOPY
(FILEMAP (NIL (1422 6156 (DATEOBJ 1432 . 2199) (DATEOBJP 2201 . 2635) (DATE.DISPLAYFN 2637 . 2959) (
DATE.IMAGEBOXFN 2961 . 3588) (DATE.PUTFN 3590 . 3788) (DATE.GETFN 3790 . 4084) (DATE.COPYFN 4086 .
4618) (DATE.BUTTONEVENTINFN 4620 . 6154)) (6200 8853 (CURRENT.DISPLAY.FONT 6210 . 6916) (
CHANGE.DATE.FORMAT 6918 . 8851)) (8906 13305 (FINDTIME 8916 . 10695) (FINDHOUR 10697 . 11058) (AMPM
11060 . 11359) (FINDDAY 11361 . 11632) (NUMP 11634 . 11863) (FINDMONTH 11865 . 12981) (FINDYEAR 12983
. 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)
(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"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>ATBL.;21)
changes to%: (FNS MAKE-READER-ENVIRONMENT)
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)
(RPAQQ ATBLCOMS
[(COMS (* ;
 "Common features of read and terminal tables")
[(COMS (* ;
 "Common features of read and terminal tables")
(DECLARE%: DONTCOPY (EXPORT (MACROS \SYNCODE \SETSYNCODE)
(RECORDS CHARTABLE))
(CONSTANTS \NSCHARHASHKEYS \NSCHARHASHOVERFLOW)
(MACROS \CREATENSCHARHASH))
(FNS GETSYNTAX SETSYNTAX SYNTAXP \COPYSYNTAX \GETCHARCODE \SETFATSYNCODE \MAPCHARTABLE)
)
(COMS (* ; "terminal tables")
(COMS (* ; "terminal tables")
(FNS CONTROL COPYTERMTABLE DELETECONTROL GETDELETECONTROL ECHOCHAR ECHOCONTROL ECHOMODE
GETECHOMODE GETCONTROL GETTERMTABLE RAISE GETRAISE RESETTERMTABLE SETTERMTABLE
TERMTABLEP \GETTERMSYNTAX \GTTERMTABLE \ORIGTERMTABLE \SETTERMSYNTAX
@ -31,16 +32,16 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
(CONSTANTS * TERMCLASSES)
(RECORDS TERMCODE TERMTABLEP)))
(INITRECORDS TERMTABLEP))
(COMS (* ; "read tables")
(COMS (* ; "read tables")
(FNS COPYREADTABLE FIND-READTABLE IN-READTABLE ESCAPE GETBRK GETREADTABLE GETSEPR
READMACROS READTABLEP READTABLEPROP RESETREADTABLE SETBRK SETREADTABLE SETSEPR
\GETREADSYNTAX \GTREADTABLE \GTREADTABLE1 \ORIGREADTABLE \READCLASSTOCODE
\SETMACROSYNTAX \SETREADSYNTAX \READTABLEP.DEFPRINT)
(PROP ARGNAMES READTABLEPROP)
(DECLARE%: EVAL@COMPILE DONTCOPY (* ;
 "READCLASSTOKENS Generates READCLASSES and some interesting SELECTQ's")
(* ;
 "OTHER must be zero because of initialization.")
(DECLARE%: EVAL@COMPILE DONTCOPY (* ;
 "READCLASSTOKENS Generates READCLASSES and some interesting SELECTQ's")
(* ;
 "OTHER must be zero because of initialization.")
[VARS READCLASSTOKENS (READCLASSES (MAPCAR READCLASSTOKENS
(FUNCTION (LAMBDA
(PAIR)
@ -48,8 +49,8 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
".RC")
(CADR PAIR]
(MACROS \COMPUTED.FORM)
(* ;
 "This macro ought to be official somehow")
(* ;
 "This macro ought to be official somehow")
(RECORDS CONTEXTS ESCAPES WAKEUPS)
(EXPORT (MACROS \GETREADMACRODEF \GTREADTABLE \GTREADTABLE1)
(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))
(FNS \ATBLSET)
(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)
(INITVARS (*LISP-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)
(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
((IGREATERP CHAR \MAXTHINCHAR)
(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)
(CHECK (type? CHARTABLE TABLE))
(* ;
 "0 is REAL.CCE, NONE.TC, OTHER.RC")
(* ;
 "0 is REAL.CCE, NONE.TC, OTHER.RC")
(COND
((ILEQ CHAR \MAXTHINCHAR)
(\PUTBASEBYTE TABLE CHAR CODE))
@ -401,8 +402,8 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
(DECLARE%: EVAL@COMPILE
(PUTPROPS \CREATENSCHARHASH MACRO (ARGS (* ;
 "added size argument for creation of \ORIGTERMTABLE during initialization.")
(PUTPROPS \CREATENSCHARHASH MACRO (ARGS (* ;
 "added size argument for creation of \ORIGTERMTABLE during initialization.")
(LIST 'HASHARRAY (OR (CAR ARGS)
'\NSCHARHASHKEYS)
'\NSCHARHASHOVERFLOW)))
@ -949,8 +950,8 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
(DECLARE%: EVAL@COMPILE
(ACCESSFNS TERMCODE ((CCECHO (LOGAND DATUM 24))
(TERMCLASS (LOGAND DATUM 7))) (* ;
 "We assume that values are appropriately shifted")
(TERMCLASS (LOGAND DATUM 7))) (* ;
 "We assume that values are appropriately shifted")
(CREATE (LOGOR CCECHO TERMCLASS)))
(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))
(DATATYPE READTABLEP ((READSA POINTER) (* ;
 "A CHARTABLE defining syntax of each char")
(READMACRODEFS POINTER) (* ;
 "A hash table associating macro chars with macro definitions")
(READMACROFLG FLAG) (* ;
 "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)")
(COMMONLISP FLAG) (* ;
 "True if table is a Common Lisp read table and hence must obey Common Lisp syntax rules")
(NUMBERBASE BITS 5) (* ; "Not used")
(CASEINSENSITIVE FLAG) (* ;
 "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")
(USESILPACKAGE FLAG) (* ;
 "If true, IL:READ ignores *PACKAGE* and reads in the IL package")
(DATATYPE READTABLEP ((READSA POINTER) (* ;
 "A CHARTABLE defining syntax of each char")
(READMACRODEFS POINTER) (* ;
 "A hash table associating macro chars with macro definitions")
(READMACROFLG FLAG) (* ;
 "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)")
(COMMONLISP FLAG) (* ;
 "True if table is a Common Lisp read table and hence must obey Common Lisp syntax rules")
(NUMBERBASE BITS 5) (* ; "Not used")
(CASEINSENSITIVE FLAG) (* ;
 "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")
(USESILPACKAGE FLAG) (* ;
 "If true, IL:READ ignores *PACKAGE* and reads in the IL package")
(NIL 5 FLAG)
(DISPATCHMACRODEFS POINTER) (* ;
 "An a-list of dispatching macro char and its dispatch definitions")
(HASHMACROCHAR BYTE) (* ;
 "The character code used in this read table for the # dispatch macro")
(ESCAPECHAR BYTE) (* ;
 "The character code used in this read table for single escape")
(MULTESCAPECHAR BYTE) (* ;
 "The character code used in this read table for multiple escape")
(PACKAGECHAR BYTE) (* ;
 "The character code used in this read table for package delimiter")
(READTBLNAME POINTER) (* ;
 "The canonical 'name' of this read table")
(DISPATCHMACRODEFS POINTER) (* ;
 "An a-list of dispatching macro char and its dispatch definitions")
(HASHMACROCHAR BYTE) (* ;
 "The character code used in this read table for the # dispatch macro")
(ESCAPECHAR BYTE) (* ;
 "The character code used in this read table for single escape")
(MULTESCAPECHAR BYTE) (* ;
 "The character code used in this read table for multiple escape")
(PACKAGECHAR BYTE) (* ;
 "The character code used in this read table for package delimiter")
(READTBLNAME POINTER) (* ;
 "The canonical 'name' of this read table")
)
READSA _ (create CHARTABLE))
)
@ -1833,14 +1834,33 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
(DEFINEQ
(MAKE-READER-ENVIRONMENT
[LAMBDA (PACKAGE READTABLE BASE FORMAT PACKAGEFORM READTABLEFORM)
(* ; "Edited 16-Aug-2021 23:44 by rmk:")
[LAMBDA (PACKAGE READTABLE BASE FORMAT PACKAGEFORM READTABLEFORM)
(* ;
 "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
REPACKAGE _ (COND
(PACKAGE (\DTEST PACKAGE 'PACKAGE))
((CL:PACKAGEP PACKAGE)
PACKAGE)
[PACKAGE (OR (CL:FIND-PACKAGE PACKAGE)
(\DEST PACKAGE 'PACKAGE]
(T *PACKAGE*))
REREADTABLE _ (COND
(READTABLE (\DTEST READTABLE 'READTABLEP))
((READTABLEP READTABLE))
[READTABLE (OR (FIND-READTABLE READTABLE)
(\DEST READTABLE 'READTABLEP]
(T *READTABLE*))
REBASE _ (COND
(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
2021))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (18036 29188 (GETSYNTAX 18046 . 22877) (SETSYNTAX 22879 . 23952) (SYNTAXP 23954 . 26451)
(\COPYSYNTAX 26453 . 27170) (\GETCHARCODE 27172 . 27460) (\SETFATSYNCODE 27462 . 28753) (
\MAPCHARTABLE 28755 . 29186)) (29221 44187 (CONTROL 29231 . 29483) (COPYTERMTABLE 29485 . 29852) (
DELETECONTROL 29854 . 32495) (GETDELETECONTROL 32497 . 33459) (ECHOCHAR 33461 . 34902) (ECHOCONTROL
34904 . 35361) (ECHOMODE 35363 . 35609) (GETECHOMODE 35611 . 35775) (GETCONTROL 35777 . 35943) (
GETTERMTABLE 35945 . 36012) (RAISE 36014 . 36440) (GETRAISE 36442 . 36604) (RESETTERMTABLE 36606 .
37690) (SETTERMTABLE 37692 . 37926) (TERMTABLEP 37928 . 38089) (\GETTERMSYNTAX 38091 . 38362) (
\GTTERMTABLE 38364 . 38700) (\ORIGTERMTABLE 38702 . 42312) (\SETTERMSYNTAX 42314 . 42949) (
\TERMCLASSTOCODE 42951 . 43380) (\TERMCODETOCLASS 43382 . 43769) (\LITCHECK 43771 . 44185)) (46717
70541 (COPYREADTABLE 46727 . 46925) (FIND-READTABLE 46927 . 47074) (IN-READTABLE 47076 . 47236) (
ESCAPE 47238 . 47491) (GETBRK 47493 . 47631) (GETREADTABLE 47633 . 47769) (GETSEPR 47771 . 47909) (
READMACROS 47911 . 48174) (READTABLEP 48176 . 48339) (READTABLEPROP 48341 . 53499) (RESETREADTABLE
53501 . 57748) (SETBRK 57750 . 59360) (SETREADTABLE 59362 . 59550) (SETSEPR 59552 . 61094) (
\GETREADSYNTAX 61096 . 63786) (\GTREADTABLE 63788 . 64013) (\GTREADTABLE1 64015 . 64271) (
\ORIGREADTABLE 64273 . 66181) (\READCLASSTOCODE 66183 . 66634) (\SETMACROSYNTAX 66636 . 68431) (
\SETREADSYNTAX 68433 . 69494) (\READTABLEP.DEFPRINT 69496 . 70539)) (83633 88086 (\ATBLSET 83643 .
88084)) (88533 91065 (MAKE-READER-ENVIRONMENT 88543 . 89321) (EQUAL-READER-ENVIRONMENT 89323 . 90467)
(SET-READER-ENVIRONMENT 90469 . 91063)))))
(FILEMAP (NIL (18046 29198 (GETSYNTAX 18056 . 22887) (SETSYNTAX 22889 . 23962) (SYNTAXP 23964 . 26461)
(\COPYSYNTAX 26463 . 27180) (\GETCHARCODE 27182 . 27470) (\SETFATSYNCODE 27472 . 28763) (
\MAPCHARTABLE 28765 . 29196)) (29231 44197 (CONTROL 29241 . 29493) (COPYTERMTABLE 29495 . 29862) (
DELETECONTROL 29864 . 32505) (GETDELETECONTROL 32507 . 33469) (ECHOCHAR 33471 . 34912) (ECHOCONTROL
34914 . 35371) (ECHOMODE 35373 . 35619) (GETECHOMODE 35621 . 35785) (GETCONTROL 35787 . 35953) (
GETTERMTABLE 35955 . 36022) (RAISE 36024 . 36450) (GETRAISE 36452 . 36614) (RESETTERMTABLE 36616 .
37700) (SETTERMTABLE 37702 . 37936) (TERMTABLEP 37938 . 38099) (\GETTERMSYNTAX 38101 . 38372) (
\GTTERMTABLE 38374 . 38710) (\ORIGTERMTABLE 38712 . 42322) (\SETTERMSYNTAX 42324 . 42959) (
\TERMCLASSTOCODE 42961 . 43390) (\TERMCODETOCLASS 43392 . 43779) (\LITCHECK 43781 . 44195)) (46727
70551 (COPYREADTABLE 46737 . 46935) (FIND-READTABLE 46937 . 47084) (IN-READTABLE 47086 . 47246) (
ESCAPE 47248 . 47501) (GETBRK 47503 . 47641) (GETREADTABLE 47643 . 47779) (GETSEPR 47781 . 47919) (
READMACROS 47921 . 48184) (READTABLEP 48186 . 48349) (READTABLEPROP 48351 . 53509) (RESETREADTABLE
53511 . 57758) (SETBRK 57760 . 59370) (SETREADTABLE 59372 . 59560) (SETSEPR 59562 . 61104) (
\GETREADSYNTAX 61106 . 63796) (\GTREADTABLE 63798 . 64023) (\GTREADTABLE1 64025 . 64281) (
\ORIGREADTABLE 64283 . 66191) (\READCLASSTOCODE 66193 . 66644) (\SETMACROSYNTAX 66646 . 68441) (
\SETREADSYNTAX 68443 . 69504) (\READTABLEP.DEFPRINT 69506 . 70549)) (83643 88096 (\ATBLSET 83653 .
88094)) (88543 91975 (MAKE-READER-ENVIRONMENT 88553 . 90231) (EQUAL-READER-ENVIRONMENT 90233 . 91377)
(SET-READER-ENVIRONMENT 91379 . 91973)))))
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)
(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"
{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>IOCHAR.;4)
changes to%: (VARS IOCHARCOMS)
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)
@ -38,17 +40,17 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 2018,
(\MIN.SEARCH.LENGTH 100)))
(INITRESOURCES \FFDELTA1 \FFDELTA2 \FFPATCHAR))
[COMS
(* ;; "DATE Functions")
(* ;; "DATE Functions")
(FNS DATE DATEFORMAT GDATE IDATE \IDATESCANTOKEN \IDATE-PARSE-MONTH \OUTDATE
\OUTDATE-STRING \RPLRIGHT \UNPACKDATE \PACKDATE \DTSCAN \ISDST? \CHECKDSTCHANGE)
(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)
(\BeginDST 98)
(\EndDST 304)
(\BeginDST 74)
(\EndDST 312)
(\DayLightSavings T))
(ADDVARS (TIME.ZONES (8 "PST" "PDT")
(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*))
(* ;;; "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)
PACKAGE))
(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)))
(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)
(COND
((ILEQ CHAR CASIZE)(* ;
 "If it's in the table, use the table value")
((ILEQ CHAR CASIZE)(* ;
 "If it's in the table, use the table value")
(\GETBASEBYTE CABASE CHAR))
(T (* ;
 "Off the end -- assume it's itself")
(T (* ;
 "Off the end -- assume it's itself")
CHAR))))
)
)
@ -1326,9 +1328,9 @@ DONTCOPY
(RPAQ? \TimeZoneComp 8)
(RPAQ? \BeginDST 98)
(RPAQ? \BeginDST 74)
(RPAQ? \EndDST 304)
(RPAQ? \EndDST 312)
(RPAQ? \DayLightSavings T)
@ -1372,15 +1374,15 @@ DONTCOPY
(PUTPROPS IOCHAR COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990
1991 2018 2020))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (3507 7301 (CHCON 3517 . 4367) (UNPACK 4369 . 5263) (DCHCON 5265 . 6532) (DUNPACK 6534
. 7299)) (7302 18817 (UALPHORDER 7312 . 7408) (ALPHORDER 7410 . 9213) (CONCAT 9215 . 9860) (
CONCATCODES 9862 . 10048) (PACKC 10050 . 12653) (PACK 12655 . 13234) (PACK* 13236 . 14958) (\PACK.ITEM
14960 . 15415) (STRPOS 15417 . 18815)) (18819 19108 (XCL:PACK 18819 . 19108)) (19110 19360 (XCL:PACK*
19110 . 19360)) (20078 22469 (STRPOSL 20088 . 21714) (MAKEBITTABLE 21716 . 22467)) (22631 23108 (
CASEARRAY 22641 . 22831) (UPPERCASEARRAY 22833 . 23106)) (23430 47032 (FILEPOS 23440 . 33352) (
FFILEPOS 33354 . 44467) (\SETUP.FFILEPOS 44469 . 47030)) (47820 89067 (DATE 47830 . 47916) (DATEFORMAT
47918 . 48010) (GDATE 48012 . 48123) (IDATE 48125 . 59796) (\IDATESCANTOKEN 59798 . 61077) (
\IDATE-PARSE-MONTH 61079 . 64775) (\OUTDATE 64777 . 77525) (\OUTDATE-STRING 77527 . 78142) (\RPLRIGHT
78144 . 78382) (\UNPACKDATE 78384 . 84175) (\PACKDATE 84177 . 87497) (\DTSCAN 87499 . 87641) (\ISDST?
87643 . 88150) (\CHECKDSTCHANGE 88152 . 89065)))))
(FILEMAP (NIL (3448 7242 (CHCON 3458 . 4308) (UNPACK 4310 . 5204) (DCHCON 5206 . 6473) (DUNPACK 6475
. 7240)) (7243 18758 (UALPHORDER 7253 . 7349) (ALPHORDER 7351 . 9154) (CONCAT 9156 . 9801) (
CONCATCODES 9803 . 9989) (PACKC 9991 . 12594) (PACK 12596 . 13175) (PACK* 13177 . 14899) (\PACK.ITEM
14901 . 15356) (STRPOS 15358 . 18756)) (18760 19049 (XCL:PACK 18760 . 19049)) (19051 19301 (XCL:PACK*
19051 . 19301)) (20019 22410 (STRPOSL 20029 . 21655) (MAKEBITTABLE 21657 . 22408)) (22572 23049 (
CASEARRAY 22582 . 22772) (UPPERCASEARRAY 22774 . 23047)) (23371 46973 (FILEPOS 23381 . 33293) (
FFILEPOS 33295 . 44408) (\SETUP.FFILEPOS 44410 . 46971)) (47761 89008 (DATE 47771 . 47857) (DATEFORMAT
47859 . 47951) (GDATE 47953 . 48064) (IDATE 48066 . 59737) (\IDATESCANTOKEN 59739 . 61018) (
\IDATE-PARSE-MONTH 61020 . 64716) (\OUTDATE 64718 . 77466) (\OUTDATE-STRING 77468 . 78083) (\RPLRIGHT
78085 . 78323) (\UNPACKDATE 78325 . 84116) (\PACKDATE 84118 . 87438) (\DTSCAN 87440 . 87582) (\ISDST?
87584 . 88091) (\CHECKDSTCHANGE 88093 . 89006)))))
STOP

BIN
sources/IOCHAR.LCOM
View File

Binary file not shown.