github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-01-26 04:12:03 +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

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.