(FILECREATED "12-Apr-85 15:33:32" {ERIS}<LISPCORE>SOURCES>PROMPTREMINDERS.;1 73123Q
changes to: (FNS SETREMINDER REMINDER.NEXTREMINDDATE \PUTREMINDER \REMINDER.PROC)
previous date: " 5-Dec-84 18:42:02" {ERIS}<LISPUSERS>PROMPTREMINDERS.;24)
(* Copyright (c) 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT PROMPTREMINDERSCOMS)
(RPAQQ PROMPTREMINDERSCOMS [(COMS (DECLARE: DONTCOPY (MACROS NNLITATOM \CHECKTYPE \NULL.OR.FIXP
\CHARS.OR.FIXP)
(PROP MACRO NCREATE)
(MACROS TIMERSUBTRACT)))
(DECLARE: EVAL@COMPILE DONTCOPY (RECORDS PERIODIC.PROMPT.REMINDER)
(RESOURCES \REMINDER.HOLD.TIMER \REMINDER.FLASH.TIMER \REMINDER.LITTLE.TIMER))
(INITRESOURCES \REMINDER.HOLD.TIMER \REMINDER.FLASH.TIMER \REMINDER.LITTLE.TIMER)
(RECORDS \SHOWABLE.PROMPT.REMINDER)
(FNS SETREMINDER ACTIVEREMINDERNAMES INSPECTREMINDER REMINDER.NEXTREMINDDATE
REMINDER.EXPIRATIONDATE REMINDER.PERIOD)
(PROP ARGNAMES REMINDER.NEXTREMINDDATE REMINDER.EXPIRATIONDATE REMINDER.PERIOD)
(FNS \PUTREMINDER \GETREMINDER \DELREMINDER)
(FNS PERIODICALLYCHECKREMINDERS UNTILKEYDOWNP \PR.WINKMESSAGE \PR.KBDChangedP)
(VARS (\PR.REMOVALS NIL))
[INITVARS (DEFAULT.REMINDER.DURATION 74Q)
(DEFAULT.REMINDER.WINKINGDURATION 12Q)
(PERIODIC.PROMPT.REMINDERS NIL)
(REMINDERSTREAM (SELECTQ (SYSTEMTYPE)
(D PROMPTWINDOW)
(PROGN (RPAQ \RCLKSECOND 1750Q)
T]
(GLOBALVARS \PR.REMOVALS REMINDERSTREAM \RCLKSECOND)
(PROP GLOBALVAR PERIODIC.PROMPT.REMINDERS DEFAULT.REMINDER.DURATION
DEFAULT.REMINDER.WINKINGDURATION DEFAULT.REMINDER.PERIOD)
(FILEPKGCOMS REMINDERS)
(FNS \REMINDER.PROC)
[DECLARE: COPYWHEN (EQ COMPILEMODE (QUOTE D))
(INITVARS (CLOSEREMINDERSTREAMFLG NIL))
(VARS (\REMINDER.EVENT (CREATE.EVENT (QUOTE PERIODIC.PROMPT.REMINDERS)))
(\FRCLKSECOND (FLOAT \RCLKSECOND))
(\KEYBOARDLST NIL))
(GLOBALVARS CLOSEREMINDERSTREAMFLG \REMINDER.EVENT \FRCLKSECOND \KEYBOARDLST)
(GLOBALVARS \EM.KBDAD0 \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3 \EM.UTILIN \EM.KBDAD4
\EM.KBDAD5)
(P (DEL.PROCESS (QUOTE REMINDERS.watchDog))
(MAPC (QUOTE (LOGOUTFORMS SYSOUTFORMS MAKESYSFORMS))
(FUNCTION (LAMBDA (X)
(MAPC [QUOTE ([BEFORE (PROGN (SETQ \KEYBOARDLST)
(DEL.PROCESS (QUOTE
REMINDERS.watchDog]
(AFTER (PERIODICALLYCHECKREMINDERS
(QUOTE RESTART]
(FUNCTION (LAMBDA
(Y)
([LAMBDA
(VAR FORM VAL)
(COND
[(BOUNDP VAR)
(OR (MEMBER FORM (SETQ
VAL
(EVALV VAR)))
(SET VAR (CONS FORM VAL]
(T (SET VAR (LIST FORM]
(PACK* (CAR Y)
X)
(CADR Y]
[P (NLSETQ (PERIODICALLYCHECKREMINDERS (QUOTE RESTART)))
(SELECTQ (SYSTEMTYPE)
(D)
(PROGN (ADDTOVAR PROMPTCHARFORMS (PERIODICALLYCHECKREMINDERS]
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA REMINDER.PERIOD
REMINDER.EXPIRATIONDATE
REMINDER.NEXTREMINDDATE])
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTPROPS NNLITATOM MACRO (OPENLAMBDA (X)
(AND X (LITATOM X]
[PUTPROPS \CHECKTYPE MACRO (X (PROG ((VAR (CAR X))
(PRED (CADR X)))
(if [AND (LISTP PRED)
(MEMB (CAR PRED)
(QUOTE (QUOTE FUNCTION]
then
(SETQ PRED (LIST (CADR PRED)
VAR)))
(RETURN (SUBPAIR (QUOTE (MSG VAR PRED))
(LIST (CONCAT
"
is not a suitable value for the variable: "
VAR)
VAR PRED)
(QUOTE (until PRED do (SETQ VAR
(ERROR VAR MSG]
[PUTPROPS \NULL.OR.FIXP MACRO (OPENLAMBDA (X)
(OR (NULL X)
(FIXP X]
[PUTPROPS \CHARS.OR.FIXP MACRO (OPENLAMBDA (X)
(OR (FIXP X)
(STRINGP X)
(LITATOM X]
)
(PUTPROPS NCREATE MACRO (X (if (EQUAL (CAR X)
(QUOTE (QUOTE FIXP)))
then (QUOTE (IPLUS 3641100Q))
else (QUOTE IGNOREMACRO))))
(DECLARE: EVAL@COMPILE
[PROGN (PUTPROPS TIMERSUBTRACT DMACRO (OPENLAMBDA (TIMER OLDTIMER)
(\BOXIDIFFERENCE OLDTIMER TIMER)))
(PUTPROPS TIMERSUBTRACT MACRO (OPENLAMBDA (TIMER OLDTIMER)
(IDIFFERENCE OLDTIMER TIMER]
)
)
(DECLARE: EVAL@COMPILE DONTCOPY
[DECLARE: EVAL@COMPILE
(TYPERECORD PERIODIC.PROMPT.REMINDER (REMINDER.TIMEOUTBOX REMINDER.MESSAGE REMINDER.PERIOD
REMINDER.WINKINGDURATION REMINDER.DURATION
REMINDER.FINALTIME REMINDER.NAME)
REMINDER.TIMEOUTBOX ←(SETUPTIMER 0)
[ACCESSFNS ([REMINDER.NEXTREMINDDATE
([LAMBDA (TIMEBOX)
(DECLARE (LOCALVARS TIMEBOX))
(AND (\TIMER.TIMERP TIMEBOX)
(GDATE (SELECTQ (SYSTEMTYPE)
(D (LOGXOR MIN.FIXP TIMEBOX))
(IPLUS TIMEBOX (IDIFFERENCE (IDATE)
(IQUOTIENT
(CLOCK 0)
1750Q]
(fetch REMINDER.TIMEOUTBOX of DATUM))
(PROG2 (replace REMINDER.TIMEOUTBOX of DATUM
with (SETUPTIMER.DATE NEWVALUE (fetch REMINDER.TIMEOUTBOX
of DATUM)))
(OR (STRINGP NEWVALUE)
(fetch REMINDER.NEXTREMINDDATE of DATUM]
(REMINDER.EXPIRATIONDATE
([LAMBDA (TIMEBOX)
(DECLARE (LOCALVARS TIMEBOX))
(AND (\TIMER.TIMERP TIMEBOX)
(GDATE (SELECTQ (SYSTEMTYPE)
(D (LOGXOR MIN.FIXP TIMEBOX))
(IPLUS TIMEBOX (IDIFFERENCE (IDATE)
(IQUOTIENT
(CLOCK 0)
1750Q]
(fetch REMINDER.FINALTIME of DATUM))
(PROG2 (replace REMINDER.FINALTIME of DATUM with (SETUPTIMER.DATE NEWVALUE))
(fetch REMINDER.EXPIRATIONDATE of DATUM])
]
(DECLARE: EVAL@COMPILE
[PUTDEF (QUOTE \REMINDER.HOLD.TIMER)
(QUOTE RESOURCES)
(QUOTE (NEW (SETUPTIMER 0 NIL (QUOTE TICKS]
[PUTDEF (QUOTE \REMINDER.FLASH.TIMER)
(QUOTE RESOURCES)
(QUOTE (NEW (SETUPTIMER 0 NIL (QUOTE TICKS]
[PUTDEF (QUOTE \REMINDER.LITTLE.TIMER)
(QUOTE RESOURCES)
(QUOTE (NEW (SETUPTIMER 0 NIL (QUOTE TICKS]
)
)
(/SETTOPVAL (QUOTE \\REMINDER.HOLD.TIMER.GLOBALRESOURCE))
(/SETTOPVAL (QUOTE \\REMINDER.FLASH.TIMER.GLOBALRESOURCE))
(/SETTOPVAL (QUOTE \\REMINDER.LITTLE.TIMER.GLOBALRESOURCE))
[DECLARE: EVAL@COMPILE
(RECORD \SHOWABLE.PROMPT.REMINDER (NIL NIL \REMINDER.MESSAGE \REMINDER.PERIOD
\REMINDER.WINKINGDURATION \REMINDER.DURATION)
(CREATE (ERROR DATUM "Creations not allowed on this record"))
[ACCESSFNS ((\REMINDER.NEXTREMINDDATE (REMINDER.NEXTREMINDDATE
DATUM)
(REMINDER.NEXTREMINDDATE
DATUM NEWVALUE))
(\REMINDER.EXPIRATIONDATE (REMINDER.EXPIRATIONDATE
DATUM)
(REMINDER.EXPIRATIONDATE
DATUM NEWVALUE])
]
(DEFINEQ
(SETREMINDER
[LAMBDA (NAME PERIOD MESSAGE INITIALDELAY EXPIRATION REMINDINGDURATION WINKINGDURATION)
(* lmm "12-Apr-85 13:13")
(\CHECKTYPE NAME (QUOTE LITATOM))
(\CHECKTYPE PERIOD (QUOTE \NULL.OR.FIXP))
(\CHECKTYPE INITIALDELAY (QUOTE \CHARS.OR.FIXP))
(PROG ((RNAME (OR NAME (GENSYM)))
REMINDER)
[if [NULL (SETQ REMINDER (GETDEF RNAME (QUOTE REMINDERS)
NIL
(QUOTE NOERROR]
then (* Big time delay before first "reminding" to allow
time for the completion of this function!)
(SETQ REMINDER (create PERIODIC.PROMPT.REMINDER
REMINDER.TIMEOUTBOX ←(SETUPTIMER 37200Q NIL (QUOTE SECONDS]
(replace REMINDER.MESSAGE of REMINDER with (OR MESSAGE RNAME))
(replace REMINDER.DURATION of REMINDER with (OR (FIXP REMINDINGDURATION)
DEFAULT.REMINDER.DURATION))
(replace REMINDER.WINKINGDURATION of (PROG1 REMINDER
(* Comment PPLossage))
with (OR (FIXP WINKINGDURATION)
DEFAULT.REMINDER.WINKINGDURATION))
(PUTDEF RNAME (QUOTE REMINDERS)
REMINDER)
(* This call is made even for "old" reminders, to get the action of MARKASCHANGED * Note also how the PERIOD was
null during this time, so that it didn't reset the timer.)
(replace REMINDER.PERIOD of REMINDER with PERIOD)
[replace REMINDER.TIMEOUTBOX of REMINDER with (if (OR (STRINGP INITIALDELAY)
(AND INITIALDELAY (LITATOM
INITIALDELAY)))
then (SETUPTIMER.DATE INITIALDELAY
(fetch
REMINDER.TIMEOUTBOX
of REMINDER))
else (SETUPTIMER (OR INITIALDELAY PERIOD 0)
(fetch REMINDER.TIMEOUTBOX
of REMINDER)
(QUOTE SECONDS]
(if EXPIRATION
then
(* * Third arg to REMINDER.NEXTREMINDDATE says dont mark as changed.)
(REMINDER.EXPIRATIONDATE REMINDER (if (FIXP EXPIRATION)
then (IPLUS EXPIRATION (IDATE (
REMINDER.NEXTREMINDDATE REMINDER)))
else (STRINGP EXPIRATION))
T))
(SELECTQ (SYSTEMTYPE)
(D (NOTIFY.EVENT \REMINDER.EVENT))
NIL)
(RETURN RNAME])
(ACTIVEREMINDERNAMES
(LAMBDA NIL (* JonL "29-NOV-82 16:58")
(MAPCAR PERIODIC.PROMPT.REMINDERS (FUNCTION CAR))))
(INSPECTREMINDER
(LAMBDA (NAME) (* JonL " 9-May-84 02:25")
(AND (NNLITATOM NAME)
(HASDEF NAME (QUOTE REMINDERS))
(SELECTQ (SYSTEMTYPE)
(D (* NOCOPY so that one can SET the fields from the
inspectWindow)
(INSPECT (GETDEF NAME (QUOTE REMINDERS)
NIL
(QUOTE NOCOPY))
(QUOTE \SHOWABLE.PROMPT.REMINDER)))
((LAMBDA (DEF)
(printout NIL T "Message: " (fetch REMINDER.MESSAGE of DEF)
T "Period: " (fetch REMINDER.PERIOD of DEF)
.TAB 20 "Winking: " (fetch REMINDER.WINKINGDURATION of DEF)
.TAB 40 "Reminding: " (fetch REMINDER.DURATION of DEF)
T "NextRemindDate: " (REMINDER.NEXTREMINDDATE NAME))
(AND (SETQ DEF (REMINDER.EXPIRATIONDATE NAME))
(printout NIL T "NextExpiration: " DEF))
(TERPRI))
(GETDEF NAME (QUOTE REMINDERS)
NIL
(QUOTE NOCOPY)))))))
(REMINDER.NEXTREMINDDATE
[LAMBDA N (* lmm "12-Apr-85 13:22")
(* * 1-arg case is only asking for information; multi-arg for update; 3'rd arg, if non-null, says don't mark as
changed.)
(AND (IGEQ N 1)
(LET [(DEF (if (type? PERIODIC.PROMPT.REMINDER (ARG N 1))
then (ARG N 1)
else (GETDEF (ARG N 1)
(QUOTE REMINDERS)
NIL
(QUOTE (NOERROR NOCOPY]
(AND (PROG1 DEF (* Comment PPLossage))
(LET ((SDATE (fetch REMINDER.NEXTREMINDDATE of DEF)))
(if (EQ N 1)
then SDATE
else [SETQ NEWDATE (OR (STRINGP (ARG N 2))
(GDATE (ARG N 2]
(if [AND (NOT (IEQP (IDATE SDATE)
(IDATE NEWDATE)))
(OR (ILEQ N 2)
(NULL (ARG N 3]
then (MARKASCHANGED (fetch REMINDER.NAME of DEF)
(QUOTE REMINDERS)
(QUOTE CHANGED)))
(NOTIFY.EVENT \REMINDER.EVENT)
(replace REMINDER.NEXTREMINDDATE of DEF with NEWDATE])
(REMINDER.EXPIRATIONDATE
(LAMBDA N (* JonL " 9-Nov-84 01:02")
(* * 1-arg case is only asking for information; multi-arg for update; 3'rd arg, if non-null, says don't mark as
changed.)
(PROG (DEF SDATE NEWDATE)
(if (OR (NOT (IGEQ N 1))
(NULL (SETQ DEF (if (type? PERIODIC.PROMPT.REMINDER (ARG N 1))
then (ARG N 1)
else (GETDEF (ARG N 1)
(QUOTE REMINDERS)
NIL
(QUOTE (NOERROR NOCOPY)))))))
then (RETURN NIL))
(SETQ SDATE (fetch REMINDER.EXPIRATIONDATE of DEF))
(* Note that SDATE must be either a STRINGP or NIL)
(if (IGREATERP N 1)
then (SETQ NEWDATE (OR (STRINGP (ARG N 2))
(GDATE (ARG N 2))))
(if (AND (NOT (IEQP (IDATE SDATE)
(OR (FIXP (IDATE NEWDATE))
-1)))
(OR (ILEQ N 2)
(NULL (ARG N 3))))
then (MARKASCHANGED (fetch REMINDER.NAME of DEF)
(QUOTE REMINDERS)
(QUOTE CHANGED)))
(replace REMINDER.EXPIRATIONDATE of DEF with (SETQ SDATE NEWDATE)))
(RETURN SDATE))))
(REMINDER.PERIOD
(LAMBDA N (* JonL "11-Jun-84 13:49")
(AND (IGEQ N 1)
((LAMBDA (DEF PERIOD)
(AND (PROG1 DEF (* Comment PPLossage))
((LAMBDA (PERIOD NEWPERIOD)
(if (IEQP N 1)
then PERIOD
else (OR (IGEQ (SETQ NEWPERIOD (FIX (ARG N 2)))
1)
(ERRORX (LIST 27 NEWPERIOD)))
(if (NOT (IEQP PERIOD NEWPERIOD))
then (MARKASCHANGED (fetch REMINDER.NAME of DEF)
(QUOTE REMINDERS)
(QUOTE CHANGED)))
(replace REMINDER.PERIOD of DEF with NEWPERIOD)))
(fetch REMINDER.PERIOD of DEF))))
(if (type? PERIODIC.PROMPT.REMINDER (ARG N 1))
then (ARG N 1)
else (GETDEF (ARG N 1)
(QUOTE REMINDERS)
NIL
(QUOTE (NOERROR NOCOPY))))))))
)
(PUTPROPS REMINDER.NEXTREMINDDATE ARGNAMES (REMINDER (OPTIONAL: NEWVALUE)))
(PUTPROPS REMINDER.EXPIRATIONDATE ARGNAMES (REMINDER (OPTIONAL: NEWVALUE)))
(PUTPROPS REMINDER.PERIOD ARGNAMES (REMINDER (OPTIONAL: NEWVALUE)))
(DEFINEQ
(\PUTREMINDER
[LAMBDA (NAME FILEPKGTYPE DEF) (* lmm "12-Apr-85 13:48")
(DECLARE (GLOBALVARS PERIODIC.PROMPT.REMINDERS))
[if (OR (NULL NAME)
(NOT (LITATOM NAME))
(NEQ FILEPKGTYPE (QUOTE REMINDERS)))
then (ERRORX (LIST 33Q (if (EQ FILEPKGTYPE (QUOTE REMINDERS))
then NAME
else FILEPKGTYPE]
(if (NOT (type? PERIODIC.PROMPT.REMINDER DEF))
then (ERRORX (LIST 33Q DEF)))
(PROG ((OLDDEF (ASSOC NAME PERIODIC.PROMPT.REMINDERS))
(PERIOD (fetch REMINDER.PERIOD of DEF)))
(replace REMINDER.NAME of DEF)
(MARKASCHANGED (PROG1 NAME (* Comment PPLossage))
FILEPKGTYPE
(if (NULL OLDDEF)
then (* AHA! A new definiton!)
(/SETTOPVAL (QUOTE PERIODIC.PROMPT.REMINDERS)
(CONS (LIST NAME DEF)
PERIODIC.PROMPT.REMINDERS))
(QUOTE DEFINED)
elseif (EQUAL (CDDR DEF)
(CDDR (CADR OLDDEF)))
then (* Blaaag! Notice how the CDDR depends upon
PERIODIC.PROMPT.REMINDER being a TYPERECORD so as to
skip checking the REMINDER.TIMEOUTBOX)
(RETURN)
else (/RPLACA (CDR OLDDEF)
DEF)
(QUOTE CHANGED)))
[AND (FIXP PERIOD)
(replace REMINDER.TIMEOUTBOX of DEF with (SETUPTIMER PERIOD (fetch REMINDER.TIMEOUTBOX
of DEF)
(QUOTE SECONDS]
(NOTIFY.EVENT \REMINDER.EVENT))
NAME])
(\GETREMINDER
(LAMBDA (NAME TYPE) (* JonL "21-NOV-82 17:11")
(CADR (ASSOC NAME PERIODIC.PROMPT.REMINDERS))))
(\DELREMINDER
(LAMBDA (NAME FILEPKGTYPE) (* JonL "26-FEB-83 12:24")
(if (OR (NULL NAME)
(NOT (LITATOM NAME))
(NEQ FILEPKGTYPE (QUOTE REMINDERS)))
then (ERRORX (LIST 27 (if (EQ FILEPKGTYPE (QUOTE REMINDERS))
then NAME
else FILEPKGTYPE))))
(PROG ((OLDDEF (ASSOC NAME PERIODIC.PROMPT.REMINDERS)))
(if OLDDEF
then (MARKASCHANGED NAME FILEPKGTYPE (QUOTE DELETED))
(/SETTOPVAL (QUOTE PERIODIC.PROMPT.REMINDERS)
(REMOVE OLDDEF PERIODIC.PROMPT.REMINDERS))
(RETURN T)))))
)
(DEFINEQ
(PERIODICALLYCHECKREMINDERS
(LAMBDA (RESETP) (* JonL " 5-Dec-84 18:35")
(SELECTQ (SYSTEMTYPE)
(D (if (EQ RESETP (QUOTE RESTART))
then
(* * This handles restarting after sysout etc. Note that moving from one machine to another may involve different
values for \RCLKSECOND)
(SETQ \KEYBOARDLST (LIST \EM.KBDAD0 \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3
\EM.UTILIN \EM.KBDAD4 \EM.KBDAD5))
(OR (FIND.PROCESS)
(ADD.PROCESS (QUOTE (\REMINDER.PROC))
(QUOTE NAME)
(QUOTE REMINDERS.watchDog)
(QUOTE RESTARTABLE)
(QUOTE HARDRESET)))
(SETQ \FRCLKSECOND (FLOAT \RCLKSECOND))))
NIL)
(RESETLST (SETQ \PR.REMOVALS)
(RESETSAVE NIL (QUOTE (PROGN (MAPC \PR.REMOVALS (FUNCTION (LAMBDA (X)
(DELDEF (CAR X)
(QUOTE REMINDERS))))))))
(PROG ((RSDSPP (SELECTQ (SYSTEMTYPE)
(D (if (DISPLAYSTREAMP REMINDERSTREAM)
then T
else (OR (STREAMP REMINDERSTREAM)
(SETQ REMINDERSTREAM (GETSTREAM REMINDERSTREAM
(QUOTE OUTPUT))))
NIL))
NIL))
REMINDER Reminder'sTimer Reminmder'sPeriod Reminder'sExpiration MESSAGE FLASHFLG)
(DECLARE (SPECVARS RSDSPP FLASHFLG MESSAGE))
(for X in PERIODIC.PROMPT.REMINDERS
do (SETQ REMINDER (CADR X))
(if (AND (SETQ Reminder'sExpiration (fetch REMINDER.FINALTIME of REMINDER))
(OR (NOT (\TIMER.TIMERP Reminder'sExpiration))
(TIMEREXPIRED? Reminder'sExpiration (QUOTE SECONDS))))
then (* An expiration date was set, and he has expired!)
(push \PR.REMOVALS X)
elseif (OR (NULL (SETQ Reminder'sTimer (fetch REMINDER.TIMEOUTBOX
of REMINDER)))
(AND Reminder'sTimer (NOT (\TIMER.TIMERP Reminder'sTimer))
(PROG1 T (replace REMINDER.TIMEOUTBOX of REMINDER
with (SETQ Reminder'sTimer)))))
then (* This guy is just an old "one-shot" reminder which
has already fired off, but is being kept around for the
benefit of Denber.wbst)
(if (NULL Reminder'sExpiration)
then (* If he has a non-null expiration field, then the
previous clause will eventuall delete him.)
(push \PR.REMOVALS X))
else (SETQ Reminmder'sPeriod (FIXP (fetch REMINDER.PERIOD of REMINDER)))
(if RESETP
then (* Reset timers upon startup after SYSOUT or LOGOUT as
if the call to SETUPTIMER were made upon startup)
(if Reminmder'sPeriod
then (replace REMINDER.TIMEOUTBOX of REMINDER
with (SETUPTIMER Reminmder'sPeriod
Reminder'sTimer (QUOTE SECONDS)
)))
elseif (TIMEREXPIRED? Reminder'sTimer (QUOTE SECONDS))
then (* When a reminder's timer has expired, then flash it
at the luser, or "run" it as a form to be eval'd.)
(if Reminmder'sPeriod
then (* For periodic reminders, set the next reminder time
now, just in case he quits out of this with a ↑D)
(replace REMINDER.TIMEOUTBOX of REMINDER
with (SETUPTIMER Reminmder'sPeriod
Reminder'sTimer (QUOTE SECONDS)
))
elseif (NULL Reminder'sExpiration)
then (* After having "fired off" a one-shot reminder, then
delete it, unless of course there is a future
expiration date.)
(push \PR.REMOVALS X)
else (* This is to prevent a "kept, one-shot" reminder from
firing off continuously.)
(replace REMINDER.TIMEOUTBOX of REMINDER
with NIL))
(if (NLISTP (SETQ MESSAGE (fetch REMINDER.MESSAGE
of REMINDER)))
then (SETQ FLASHFLG)
(UNTILKEYDOWNP (FUNCTION \PR.WINKMESSAGE)
.5
(fetch REMINDER.DURATION
of REMINDER)
(fetch REMINDER.WINKINGDURATION
of REMINDER)
(FUNCTION (LAMBDA NIL
(SELECTQ (SYSTEMTYPE)
(D (BLOCK)
(RINGBELLS 3))
(PRINTBELLS)))))
(SELECTQ (SYSTEMTYPE)
(D (if RSDSPP
then (DSPRESET REMINDERSTREAM)
else (TERPRI REMINDERSTREAM)))
(TERPRI REMINDERSTREAM))
else (NLSETQ (EVAL MESSAGE)))
(if Reminmder'sPeriod
then (* Make the next reminder timeout more current.)
(replace REMINDER.TIMEOUTBOX of REMINDER
with (SETUPTIMER Reminmder'sPeriod
Reminder'sTimer (QUOTE SECONDS)
))))))
(SELECTQ (SYSTEMTYPE)
(D (AND CLOSEREMINDERSTREAMFLG RSDSPP (CLOSEW REMINDERSTREAM)))
NIL)))))
(UNTILKEYDOWNP
(LAMBDA (FN INTERVAL.SECS DURATION.SECS subCycleDuration.secs subCycleFN)
(* JonL " 5-Dec-84 18:41")
(OR (FIXP DURATION.SECS)
(SETQ DURATION.SECS (FIXR DURATION.SECS)))
(OR subCycleDuration.secs (SETQ subCycleDuration.secs DURATION.SECS))
(PROG ((INTERVAL.TICS (FIX (FTIMES (OR (FLOATP INTERVAL.SECS)
(FLOAT INTERVAL.SECS))
(OR (FLOATP \FRCLKSECOND)
(SETQ \FRCLKSECOND (FLOAT \RCLKSECOND))))))
(FIRSTTIME T)
ADDRSLST KEYMASKLST OLDKEYLST)
(SELECTQ (SYSTEMTYPE)
(D (SETQ KEYMASKLST
(LOADTIMECONSTANT (PROG ((X (ARRAY 7 (QUOTE WORD)
(MASK.1'S 0 16)
0))
J)
(SETA X 4 0)
(SETA X 5 0)
(SETA X 6 0)
(for I in (LIST (\KEYNAMETONUMBER (QUOTE MIDDLE)))
do (SETQ J (LRSH I 4))
(SETA X J
(LOGOR (ELT X J)
(MASK.1'S (IDIFFERENCE
15
(IMOD I 16))
1))))
(for I in (LIST (\KEYNAMETONUMBER (QUOTE LSHIFT))
(\KEYNAMETONUMBER (QUOTE LOCK))
(\KEYNAMETONUMBER (QUOTE RSHIFT))
(\KEYNAMETONUMBER (QUOTE CTRL)))
do (SETQ J (LRSH I 4))
(SETA X J
(BITCLEAR (ELT X J)
(MASK.1'S (IDIFFERENCE
15
(IMOD I 16))
1))))
(RETURN (for I from 0 to 6
collect (LOGXOR (ELT X I)
(MASK.1'S 0 16)))))))
(SETQ ADDRSLST (OR \KEYBOARDLST (SETQ \KEYBOARDLST
(LIST \EM.KBDAD0 \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3
\EM.UTILIN \EM.KBDAD4 \EM.KBDAD5))))
(* The masks are basically which key positions to
ignore)
(SETQ OLDKEYLST (APPEND ADDRSLST NIL))
(* First, transfer the state of the keyboard, modulo
the "masks", into the list OLDKEYLST)
(for L on OLDKEYLST as MASK in KEYMASKLST as A in ADDRSLST
do (FRPLACA L (LOGOR MASK (\GETBASE A 0)))))
NIL)
(WITH-RESOURCES (\REMINDER.HOLD.TIMER \REMINDER.FLASH.TIMER \REMINDER.LITTLE.TIMER)
(during DURATION.SECS timerUnits (QUOTE SECONDS) usingTimer
\REMINDER.HOLD.TIMER
eachtime (if FIRSTTIME
then (SETQ FIRSTTIME)
elseif subCycleFN
then (APPLY subCycleFN))
when (during subCycleDuration.secs timerUnits (QUOTE SECONDS)
usingTimer \REMINDER.FLASH.TIMER
when (during INTERVAL.TICS timerUnits (QUOTE TICKS)
usingTimer \REMINDER.LITTLE.TIMER
when (\PR.KBDChangedP OLDKEYLST ADDRSLST KEYMASKLST)
do (RETURN T) finally (APPLY FN))
do (* Wink the message at him in the PROMPTWINDOW at
roughly 1 second intervals, returning non-null if a key
is down.)
(RETURN T))
do (* AHA! Quit due to key being "down")
(RETURN))))))
(\PR.WINKMESSAGE
(LAMBDA NIL
(DECLARE (USEDFREE FLASHFLG MESSAGE RSDSPP)) (* JonL "15-Apr-84 14:46")
(if FLASHFLG
then (SELECTQ (SYSTEMTYPE)
(D (if RSDSPP
then (DSPRESET REMINDERSTREAM))
(BLOCK))
(PRIN1 (CONSTANT (CHARACTER (CHARCODE BELL)))
T))
else (PRIN3 MESSAGE REMINDERSTREAM)
(TERPRI REMINDERSTREAM))
(* * In D world, we alternate between FLASHing and not; but in other worlds, we print the message once and just
continue FLASHing at the luser.)
(SELECTQ (SYSTEMTYPE)
(D (SETQ FLASHFLG (NOT FLASHFLG)))
(if (NULL FLASHFLG)
then (SETQ FLASHFLG T)))))
(\PR.KBDChangedP
(LAMBDA (ORIGKEYLST ADDRSLST MASKLST) (* JonL "29-Mar-84 17:17")
(SELECTQ (SYSTEMTYPE)
(D (find A in ADDRSLST as WORD in ORIGKEYLST as MASK in MASKLST
suchthat (NEQ WORD (LOGOR MASK (\GETBASE A 0)))))
(READP T))))
)
(RPAQQ \PR.REMOVALS NIL)
(RPAQ? DEFAULT.REMINDER.DURATION 74Q)
(RPAQ? DEFAULT.REMINDER.WINKINGDURATION 12Q)
(RPAQ? PERIODIC.PROMPT.REMINDERS NIL)
(RPAQ? REMINDERSTREAM (SELECTQ (SYSTEMTYPE)
(D PROMPTWINDOW)
(PROGN (RPAQ \RCLKSECOND 1750Q)
T)))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \PR.REMOVALS REMINDERSTREAM \RCLKSECOND)
)
(PUTPROPS PERIODIC.PROMPT.REMINDERS GLOBALVAR T)
(PUTPROPS DEFAULT.REMINDER.DURATION GLOBALVAR T)
(PUTPROPS DEFAULT.REMINDER.WINKINGDURATION GLOBALVAR T)
(PUTPROPS DEFAULT.REMINDER.PERIOD GLOBALVAR T)
(PUTDEF (QUOTE REMINDERS) (QUOTE FILEPKGCOMS) (QUOTE ((TYPE DESCRIPTION "Periodic PROMPT Reminders"
GETDEF \GETREMINDER PUTDEF \PUTREMINDER
DELDEF \DELREMINDER))))
(DEFINEQ
(\REMINDER.PROC
[LAMBDA NIL (* lmm "12-Apr-85 13:59")
(do [AWAIT.EVENT \REMINDER.EVENT (bind (DELAY ←(TIMES 5 74Q)) for PR in PERIODIC.PROMPT.REMINDERS
bind TIMER when [AND [\TIMER.TIMERP (SETQ TIMER
(fetch
REMINDER.TIMEOUTBOX
of (CADR PR]
(NOT (TIMEREXPIRED? TIMER (QUOTE SECONDS]
do [SETQ DELAY (IMIN DELAY (TIME.UNTIL TIMER (QUOTE SECONDS]
finally (RETURN (TIMES DELAY 1750Q]
(PERIODICALLYCHECKREMINDERS])
)
(DECLARE: COPYWHEN (EQ COMPILEMODE (QUOTE D))
(RPAQ? CLOSEREMINDERSTREAMFLG NIL)
(RPAQ \REMINDER.EVENT (CREATE.EVENT (QUOTE PERIODIC.PROMPT.REMINDERS)))
(RPAQ \FRCLKSECOND (FLOAT \RCLKSECOND))
(RPAQQ \KEYBOARDLST NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS CLOSEREMINDERSTREAMFLG \REMINDER.EVENT \FRCLKSECOND \KEYBOARDLST)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \EM.KBDAD0 \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3 \EM.UTILIN \EM.KBDAD4 \EM.KBDAD5)
)
(DEL.PROCESS (QUOTE REMINDERS.watchDog))
[MAPC (QUOTE (LOGOUTFORMS SYSOUTFORMS MAKESYSFORMS))
(FUNCTION (LAMBDA (X)
(MAPC [QUOTE ([BEFORE (PROGN (SETQ \KEYBOARDLST)
(DEL.PROCESS (QUOTE REMINDERS.watchDog]
(AFTER (PERIODICALLYCHECKREMINDERS (QUOTE RESTART]
(FUNCTION (LAMBDA (Y)
([LAMBDA (VAR FORM VAL)
(COND [(BOUNDP VAR)
(OR (MEMBER FORM (SETQ VAL
(EVALV VAR)))
(SET VAR (CONS FORM VAL]
(T (SET VAR (LIST FORM]
(PACK* (CAR Y)
X)
(CADR Y]
)
(NLSETQ (PERIODICALLYCHECKREMINDERS (QUOTE RESTART)))
[SELECTQ (SYSTEMTYPE)
(D)
(PROGN (ADDTOVAR PROMPTCHARFORMS (PERIODICALLYCHECKREMINDERS]
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA REMINDER.PERIOD REMINDER.EXPIRATIONDATE REMINDER.NEXTREMINDDATE)
)
(PUTPROPS PROMPTREMINDERS COPYRIGHT ("Xerox Corporation" 3676Q 3677Q 3700Q 3701Q))
(DECLARE: DONTCOPY
(FILEMAP (NIL (15564Q 34103Q (SETREMINDER 15576Q . 22733Q) (ACTIVEREMINDERNAMES 22735Q . 23211Q) (
INSPECTREMINDER 23213Q . 25207Q) (REMINDER.NEXTREMINDDATE 25211Q . 27500Q) (REMINDER.EXPIRATIONDATE
27502Q . 32277Q) (REMINDER.PERIOD 32301Q . 34101Q)) (34457Q 41410Q (\PUTREMINDER 34471Q . 40013Q) (
\GETREMINDER 40015Q . 40256Q) (\DELREMINDER 40260Q . 41406Q)) (41411Q 65314Q (
PERIODICALLYCHECKREMINDERS 41423Q . 54315Q) (UNTILKEYDOWNP 54317Q . 63314Q) (\PR.WINKMESSAGE 63316Q .
64622Q) (\PR.KBDChangedP 64624Q . 65312Q)) (66753Q 70172Q (\REMINDER.PROC 66765Q . 70170Q)))))
STOP