(FILECREATED "20-Apr-84 12:08:14" {PHYLUM}<LISPUSERS>PROMPTREMINDERS.;15 26626
changes to: (FNS PERIODICALLYCHECKREMINDERS)
previous date: "15-Apr-84 14:46:31" {PHYLUM}<LISPUSERS>PROMPTREMINDERS.;13)
(* Copyright (c) 1982, 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT PROMPTREMINDERSCOMS)
(RPAQQ PROMPTREMINDERSCOMS ((* "Reminders" , which wake up periodically at PROMPTCHARS time, and
notify you of an "urgent" message via the PROMPTWINDOW)
(COMS (* Next FNS ought to be elsewhere)
(DECLARE: DONTCOPY (MACROS NNLITATOM \CHECKTYPE \NULL.OR.FIXP
\CHARS.OR.FIXP)
(PROP MACRO NCREATE)
(* FOO, following functionality ought to be with the
DURATION stuff.)
(MACROS TIMERSUBTRACT))
(* Lossage to be sure TIMEREXPIRED? is defined))
(DECLARE: EVAL@COMPILE DONTCOPY (RECORDS PERIODIC.PROMPT.REMINDER))
(RECORDS \SHOWABLE.PROMPT.REMINDER)
(GLOBALRESOURCES (\REMINDER.HOLD.TIMER (SETUPTIMER 0 NIL (QUOTE TICKS)))
(\REMINDER.FLASH.TIMER (SETUPTIMER 0 NIL (QUOTE TICKS)))
(\REMINDER.LITTLE.TIMER (SETUPTIMER 0 NIL (QUOTE TICKS)))
)
(FNS SETREMINDER ACTIVEREMINDERNAMES INSPECTREMINDER
REMINDER.NEXTREMINDDATE REMINDER.EXPIRATIONDATE REMINDER.PERIOD)
(FNS \PUTREMINDER \GETREMINDER \DELREMINDER)
(FNS PERIODICALLYCHECKREMINDERS UNTILKEYDOWNP \PR.WINKMESSAGE
\PR.KBDChangedP)
(INITVARS (DEFAULT.REMINDER.DURATION 60)
(DEFAULT.REMINDER.WINKINGDURATION 10)
(PERIODIC.PROMPT.REMINDERS NIL)
(\PR.REMOVALS NIL))
(GLOBALVARS \PR.REMOVALS)
(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 (REMINDERSTREAM PROMPTWINDOW)
(CLOSEREMINDERSTREAMFLG NIL))
(VARS (\REMINDER.EVENT (CREATE.EVENT (QUOTE
PERIODIC.PROMPT.REMINDERS)))
(\FRCLKSECOND (FLOAT \RCLKSECOND))
(\PERIOD.SAVEDCARET NIL))
(GLOBALVARS REMINDERSTREAM CLOSEREMINDERSTREAMFLG
\REMINDER.EVENT \FRCLKSECOND \PERIOD.SAVEDCARET)
(GLOBALVARS \RCLKSECOND \EM.KBDAD0 \EM.KBDAD1 \EM.KBDAD2
\EM.KBDAD3 \EM.UTILIN \EM.KBDAD4 \EM.KBDAD5)
(P (DEL.PROCESS (QUOTE REMINDERS.watchDog))
(ADD.PROCESS (QUOTE (\REMINDER.PROC))
(QUOTE NAME)
(QUOTE REMINDERS.watchDog)
(QUOTE RESTARTABLE)
(QUOTE HARDRESET)))
(ADDVARS (AFTERLOGOUTFORMS (PERIODICALLYCHECKREMINDERS T))
(AFTERSYSOUTFORMS (PERIODICALLYCHECKREMINDERS T))))
(DECLARE: COPYWHEN (NEQ COMPILEMODE (QUOTE D))
(INITVARS (REMINDERSTREAM T)
(\RCLKSECOND 1000))
(ADDVARS (PROMPTCHARFORMS (PERIODICALLYCHECKREMINDERS)))
(GLOBALVARS REMINDERSTREAM \RCLKSECOND))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA REMINDER.PERIOD REMINDER.EXPIRATIONDATE
REMINDER.NEXTREMINDDATE)))))
(* "Reminders" , which wake up periodically at PROMPTCHARS time, and notify you of an "urgent"
message via the PROMPTWINDOW)
(* Next FNS ought to be elsewhere)
(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 1000000))
else (QUOTE IGNOREMACRO))))
(* FOO, following functionality ought to be with the DURATION stuff.)
(DECLARE: EVAL@COMPILE
(PUTPROPS TIMERSUBTRACT DMACRO (OPENLAMBDA (TIMER OLDTIMER)
(\BOXIDIFFERENCE OLDTIMER TIMER)))
(PUTPROPS TIMERSUBTRACT MACRO (OPENLAMBDA (TIMER OLDTIMER)
(IDIFFERENCE OLDTIMER TIMER)))
)
)
(* Lossage to be sure TIMEREXPIRED? is defined)
(DECLARE: EVAL@COMPILE DONTCOPY
[DECLARE: EVAL@COMPILE
(TYPERECORD PERIODIC.PROMPT.REMINDER (REMINDER.TIMEOUTBOX REMINDER.MESSAGE REMINDER.PERIOD
REMINDER.WINKINGDURATION REMINDER.DURATION
REMINDER.FINALTIME)
REMINDER.TIMEOUTBOX ←(SETUPTIMER 0)
(ACCESSFNS ((REMINDER.NEXTREMINDDATE (GDATE (SELECTQ (SYSTEMTYPE)
(D (LOGXOR MIN.FIXP
(fetch
REMINDER.TIMEOUTBOX
of DATUM)))
(IPLUS (fetch REMINDER.TIMEOUTBOX
of DATUM)
(IDIFFERENCE
(IDATE)
(IQUOTIENT (CLOCK 0)
1000)))))
(PROG2 (replace REMINDER.TIMEOUTBOX of DATUM
with (SETUPTIMER.DATE NEWVALUE
(fetch
REMINDER.TIMEOUTBOX
of DATUM)))
(OR (STRINGP DATUM)
(fetch REMINDER.NEXTREMINDDATE
of DATUM))))
(REMINDER.EXPIRATIONDATE
(AND (fetch REMINDER.FINALTIME of DATUM)
(GDATE (SELECTQ (SYSTEMTYPE)
(D (LOGXOR MIN.FIXP (fetch REMINDER.FINALTIME
of DATUM)))
(IPLUS (fetch REMINDER.FINALTIME of DATUM)
(IDIFFERENCE (IDATE)
(IQUOTIENT (CLOCK 0)
1000))))))
(PROG2 (replace REMINDER.FINALTIME of DATUM with (SETUPTIMER.DATE NEWVALUE))
(fetch REMINDER.EXPIRATIONDATE of DATUM))))))
]
)
[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)))))
]
(DECLARE: DOEVAL@COMPILE DONTCOPY
(PUTDEF (QUOTE \REMINDER.HOLD.TIMER)
(QUOTE GLOBALRESOURCES)
(QUOTE (SETUPTIMER 0 NIL (QUOTE TICKS))))
(PUTDEF (QUOTE \REMINDER.FLASH.TIMER)
(QUOTE GLOBALRESOURCES)
(QUOTE (SETUPTIMER 0 NIL (QUOTE TICKS))))
(PUTDEF (QUOTE \REMINDER.LITTLE.TIMER)
(QUOTE GLOBALRESOURCES)
(QUOTE (SETUPTIMER 0 NIL (QUOTE TICKS))))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \REMINDER.LITTLE.TIMER \REMINDER.FLASH.TIMER \REMINDER.HOLD.TIMER)
)
(RPAQQ \REMINDER.LITTLE.TIMER NIL)
(RPAQQ \REMINDER.FLASH.TIMER NIL)
(RPAQQ \REMINDER.HOLD.TIMER NIL)
(DEFINEQ
(SETREMINDER
(LAMBDA (NAME PERIOD MESSAGE INITIALDELAY EXPIRATION REMINDINGDURATION WINKINGDURATION)
(* JonL "10-Apr-84 19:06")
(OR NAME (SETQ NAME (GENSYM)))
(\CHECKTYPE NAME (QUOTE LITATOM))
(\CHECKTYPE PERIOD (QUOTE \NULL.OR.FIXP))
(\CHECKTYPE INITIALDELAY (QUOTE \CHARS.OR.FIXP))
(PROG ((REMINDER (GETDEF NAME (QUOTE REMINDERS)
NIL
(QUOTE NOERROR)))
BOX)
(if (NULL REMINDER)
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 16000 NIL (QUOTE SECONDS)))
))
(replace REMINDER.MESSAGE of REMINDER with (OR MESSAGE NAME))
(replace REMINDER.DURATION of (PROG1 REMINDER (* Comment PPLossage))
with (OR (FIXP REMINDINGDURATION)
DEFAULT.REMINDER.DURATION))
(replace REMINDER.WINKINGDURATION of (PROG1 REMINDER
(* Comment PPLossage))
with (OR (FIXP WINKINGDURATION)
DEFAULT.REMINDER.WINKINGDURATION))
(PUTDEF NAME (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)
(SETQ BOX (fetch REMINDER.TIMEOUTBOX of REMINDER))
(if (OR (STRINGP INITIALDELAY)
(NNLITATOM INITIALDELAY))
then (SETQ BOX (SETUPTIMER.DATE INITIALDELAY BOX))
else (SETQ BOX (SETUPTIMER (OR INITIALDELAY PERIOD 0)
BOX
(QUOTE SECONDS))))
(replace REMINDER.TIMEOUTBOX of REMINDER with BOX)
(if EXPIRATION
then (replace REMINDER.FINALTIME of REMINDER
with (if (OR (STRINGP EXPIRATION)
(NNLITATOM EXPIRATION))
then (SETUPTIMER.DATE EXPIRATION)
else (PROG ((NEWBOX (SETUPTIMER 0 NIL (QUOTE SECONDS))))
(RETURN (SETUPTIMER (IPLUS (IMINUS (TIMERSUBTRACT BOX NEWBOX))
EXPIRATION)
NEWBOX
(QUOTE SECONDS)))))))
(SELECTQ (SYSTEMTYPE)
(D (NOTIFY.EVENT \REMINDER.EVENT))
NIL)
(RETURN NAME))))
(ACTIVEREMINDERNAMES
(LAMBDA NIL (* JonL "29-NOV-82 16:58")
(MAPCAR PERIODIC.PROMPT.REMINDERS (FUNCTION CAR))))
(INSPECTREMINDER
(LAMBDA (NAME) (* JonL "25-FEB-83 19:30")
(AND (NNLITATOM NAME)
(HASDEF NAME (QUOTE REMINDERS))
(SELECTQ (SYSTEMTYPE)
(D (INSPECT (GETDEF NAME (QUOTE REMINDERS))
(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)))))))
(REMINDER.NEXTREMINDDATE
(LAMBDA N (* JonL "10-Apr-84 19:07")
(AND (IGEQ N 1)
((LAMBDA (DEF)
(AND (PROG1 DEF (* Comment PPLossage))
(if (IEQP N 1)
then (fetch REMINDER.NEXTREMINDDATE of DEF)
else (replace REMINDER.NEXTREMINDDATE of DEF
with (OR (STRINGP (ARG N 2))
(GDATE (ARG N 2))))
(SELECTQ (SYSTEMTYPE)
(D (NOTIFY.EVENT \REMINDER.EVENT))
NIL))))
(if (type? PERIODIC.PROMPT.REMINDER (ARG N 1))
then (ARG N 1)
else (GETDEF (ARG N 1)
(QUOTE REMINDERS)
NIL
(QUOTE (NOERROR NOCOPY))))))))
(REMINDER.EXPIRATIONDATE
(LAMBDA N (* JonL " 7-MAR-83 21:29")
(AND (IGEQ N 1)
((LAMBDA (DEF)
(AND (PROG1 DEF (* Comment PPLossage))
(if (IEQP N 1)
then (fetch REMINDER.EXPIRATIONDATE of DEF)
else (replace REMINDER.EXPIRATIONDATE of DEF
with (OR (STRINGP (ARG N 2))
(GDATE (ARG N 2)))))))
(if (type? PERIODIC.PROMPT.REMINDER (ARG N 1))
then (ARG N 1)
else (GETDEF (ARG N 1)
(QUOTE REMINDERS)
NIL
(QUOTE (NOERROR NOCOPY))))))))
(REMINDER.PERIOD
(LAMBDA N (* JonL " 7-MAR-83 21:32")
(AND (IGEQ N 1)
((LAMBDA (DEF)
(AND (PROG1 DEF (* Comment PPLossage))
(if (IEQP N 1)
then (fetch REMINDER.PERIOD of DEF)
else ((LAMBDA (N)
(OR (IGEQ N 1)
(ERRORX (LIST 27 N)))
(replace REMINDER.PERIOD of DEF with N))
(FIX (ARG N 2))))))
(if (type? PERIODIC.PROMPT.REMINDER (ARG N 1))
then (ARG N 1)
else (GETDEF (ARG N 1)
(QUOTE REMINDERS)
NIL
(QUOTE (NOERROR NOCOPY))))))))
)
(DEFINEQ
(\PUTREMINDER
(LAMBDA (NAME FILEPKGTYPE DEF) (* JonL "10-Apr-84 19:10")
(DECLARE (GLOBALVARS PERIODIC.PROMPT.REMINDERS))
(if (OR (NULL NAME)
(NOT (LITATOM NAME))
(NEQ FILEPKGTYPE (QUOTE REMINDERS)))
then (ERRORX (LIST 27 (if (EQ FILEPKGTYPE (QUOTE REMINDERS))
then NAME
else FILEPKGTYPE))))
(if (NOT (type? PERIODIC.PROMPT.REMINDER DEF))
then (ERRORX (LIST 27 DEF)))
(PROG ((OLD (ASSOC NAME PERIODIC.PROMPT.REMINDERS))
(PERIOD (fetch REMINDER.PERIOD of DEF)))
(MARKASCHANGED (PROG1 NAME (* Comment PPLossage))
FILEPKGTYPE
(if (NULL OLD)
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 OLD)))
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 OLD)
DEF)
(QUOTE CHANGED)))
(AND (FIXP PERIOD)
(replace REMINDER.TIMEOUTBOX of DEF with (SETUPTIMER PERIOD (fetch REMINDER.TIMEOUTBOX
of DEF)
(QUOTE SECS))))
(SELECTQ (SYSTEMTYPE)
(D (NOTIFY.EVENT \REMINDER.EVENT))
NIL))
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 "20-Apr-84 12:06")
(SELECTQ (SYSTEMTYPE)
(D (if \PERIOD.SAVEDCARET
then (* Safety check for resetting the CARET, in case someone
↑D's out of the waiting loops below.)
(CARET \PERIOD.SAVEDCARET))
(SETQ \PERIOD.SAVEDCARET (CARET (QUOTE OFF))))
NIL)
(AND RESETP (SETQ \FRCLKSECOND (FLOAT \RCLKSECOND)))
(* This handles the case of dumping a sysout on, say, Dorado and then restarting it on a DLion
(where the \RCLKSECOND is different))
(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 (type? STREAM REMINDERSTREAM)
(SETQ REMINDERSTREAM (GETSTREAM REMINDERSTREAM
(QUOTE OUTPUT)))))
)
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))
(SETQ Reminmder'sPeriod (FIXP (fetch REMINDER.PERIOD of REMINDER)))
(SETQ Reminder'sExpiration (fetch REMINDER.FINALTIME of REMINDER))
(SETQ Reminder'sTimer (fetch REMINDER.TIMEOUTBOX of REMINDER))
(if (OR (NOT (\TIMER.TIMERP Reminder'sTimer))
(AND (\TIMER.TIMERP Reminder'sExpiration)
(TIMEREXPIRED? Reminder'sExpiration (QUOTE SECONDS))))
then (* Must be that this guy is "finished" now, or perhaps
in error.)
(push \PR.REMOVALS X)
elseif (AND RESETP Reminmder'sPeriod)
then (* Reset timers upon startup after SYSOUT or LOGOUT as
if the call to SETUPTIMER were made upon startup)
(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 (NULL Reminmder'sPeriod)
then (* After having once done a reminder for which there is
a NIL interval, then shut it off)
(push \PR.REMOVALS X)
(SETQ Reminmder'sPeriod)
else (* Otherwise, 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))))
(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))
(CARET (PROG1 \PERIOD.SAVEDCARET (SETQ \PERIOD.SAVEDCARET))))
NIL)))
(UNTILKEYDOWNP
(LAMBDA (FN INTERVAL.SECS DURATION.SECS subCycleDuration.secs subCycleFN)
(* JonL "10-Apr-84 20:12")
(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))
\FRCLKSECOND)))
(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 (LOADTIMECONSTANT (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)
(GLOBALRESOURCE (\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))))
)
(RPAQ? DEFAULT.REMINDER.DURATION 60)
(RPAQ? DEFAULT.REMINDER.WINKINGDURATION 10)
(RPAQ? PERIODIC.PROMPT.REMINDERS NIL)
(RPAQ? \PR.REMOVALS NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \PR.REMOVALS)
)
(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 (* JonL "11-Apr-84 16:48")
(SELECTQ (SYSTEMTYPE)
(D (bind DELAY eachtime (SETQ DELAY (CONSTANT (ITIMES 30 60 1000)))
do (OR (NULL PERIODIC.PROMPT.REMINDERS)
(for PR LO TEM in PERIODIC.PROMPT.REMINDERS
do (if (AND (SETQ TEM (fetch REMINDER.TIMEOUTBOX of (CADR PR)))
(OR (NULL LO)
(IMODLESSP LO TEM (QUOTE CELL))))
then (SETQ LO TEM))
finally (if LO
then (SETQ DELAY (ITIMES 1000 (LOGXOR (IMODDIFFERENCE
LO
(IDATE)
(QUOTE CELL))
(MASK.1'S 31 1)))))))
(AWAIT.EVENT \REMINDER.EVENT DELAY)
(PERIODICALLYCHECKREMINDERS)))
NIL)))
)
(DECLARE: COPYWHEN (EQ COMPILEMODE (QUOTE D))
(RPAQ? REMINDERSTREAM PROMPTWINDOW)
(RPAQ? CLOSEREMINDERSTREAMFLG NIL)
(RPAQ \REMINDER.EVENT (CREATE.EVENT (QUOTE PERIODIC.PROMPT.REMINDERS)))
(RPAQ \FRCLKSECOND (FLOAT \RCLKSECOND))
(RPAQQ \PERIOD.SAVEDCARET NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS REMINDERSTREAM CLOSEREMINDERSTREAMFLG \REMINDER.EVENT \FRCLKSECOND
\PERIOD.SAVEDCARET)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \RCLKSECOND \EM.KBDAD0 \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3 \EM.UTILIN \EM.KBDAD4
\EM.KBDAD5)
)
(DEL.PROCESS (QUOTE REMINDERS.watchDog))
(ADD.PROCESS (QUOTE (\REMINDER.PROC))
(QUOTE NAME)
(QUOTE REMINDERS.watchDog)
(QUOTE RESTARTABLE)
(QUOTE HARDRESET))
(ADDTOVAR AFTERLOGOUTFORMS (PERIODICALLYCHECKREMINDERS T))
(ADDTOVAR AFTERSYSOUTFORMS (PERIODICALLYCHECKREMINDERS T))
)
(DECLARE: COPYWHEN (NEQ COMPILEMODE (QUOTE D))
(RPAQ? REMINDERSTREAM T)
(RPAQ? \RCLKSECOND 1000)
(ADDTOVAR PROMPTCHARFORMS (PERIODICALLYCHECKREMINDERS))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS REMINDERSTREAM \RCLKSECOND)
)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA REMINDER.PERIOD REMINDER.EXPIRATIONDATE REMINDER.NEXTREMINDDATE)
)
(PUTPROPS PROMPTREMINDERS COPYRIGHT ("Xerox Corporation" 1982 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (7260 12878 (SETREMINDER 7270 . 9846) (ACTIVEREMINDERNAMES 9848 . 10020) (
INSPECTREMINDER 10022 . 10837) (REMINDER.NEXTREMINDDATE 10839 . 11564) (REMINDER.EXPIRATIONDATE 11566
. 12213) (REMINDER.PERIOD 12215 . 12876)) (12879 15236 (\PUTREMINDER 12889 . 14471) (\GETREMINDER
14473 . 14634) (\DELREMINDER 14636 . 15234)) (15237 23706 (PERIODICALLYCHECKREMINDERS 15247 . 19478) (
UNTILKEYDOWNP 19480 . 22682) (\PR.WINKMESSAGE 22684 . 23392) (\PR.KBDChangedP 23394 . 23704)) (24360
25172 (\REMINDER.PROC 24370 . 25170)))))
STOP