(FILECREATED "21-Jul-86 11:59:29" {ERIS}<LISPCORE>SOURCES>LLKEY.;83 142155
changes to: (VARS LLKEYCOMS)
previous date: "15-Feb-86 11:50:16" {ERIS}<LISPCORE>SOURCES>LLKEY.;82)
(* Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LLKEYCOMS)
(RPAQQ LLKEYCOMS
[(COMS (* Access to keyboard)
(FNS BKSYSCHARCODE \CLEARSYSBUF \GETKEY \NSYSBUFCHARS \SAVESYSBUF \SYSBUFP \GETSYSBUF
\PUTSYSBUF \PEEKSYSBUF)
(INITVARS (\LONGSYSBUF))
(INITVARS (\\KEYBOARDWAITBOX.GLOBALRESOURCE))
(DECLARE: DONTCOPY (RESOURCES \KEYBOARDWAITBOX))
(DECLARE: DONTCOPY (CONSTANTS (\SYSBUFSIZE 200))
(MACROS \GETREALSYSBUF)))
[DECLARE: DOCOPY DONTEVAL@LOAD (COMS (* Here because it must be done in init before PROC
loaded)
(P (MOVD? (QUOTE NILL)
(QUOTE CARET]
(COMS (* Key handler)
(FNS \KEYBOARDINIT \KEYBOARDEVENTFN \ALLOCLOCKED \SETIOPOINTERS \KEYBOARDOFF
\KEYBOARDON \KEYHANDLER \KEYHANDLER1 \RESETKEYBOARD \DOMOUSECHORDING
\DOTRANSITIONS \DECODETRANSITION MOUSECHORDWAIT \TRACKCURSOR)
(INITVARS (\MOUSECHORDTICKS)
(\MOUSECHORDMILLISECONDS 50))
(DECLARE: DONTEVAL@LOAD DOCOPY (P (\KEYBOARDINIT)))
[DECLARE: DONTCOPY (MACROS .NOTELASTUSERACTION)
(CONSTANTS ALLUP \CTRLMASK \METABIT)
(CONSTANTS * DLMOUSEBITS)
(CONSTANTS * DLMOUSESTATES)
(CONSTANTS * TRANSITIONFLAGS)
(MACROS \TRANSINDEX ARMEDCODE TRANSITIONSHIFTCODE TRANSITIONCODE TRANSITIONFLAGS
)
(EXPORT (RECORDS KEYACTION)
(CONSTANTS \NKEYS))
(RECORDS RING)
(COMS (* can get rid of shiftstate after clients have been fixed)
(RECORDS SHIFTSTATE)
(GLOBALVARS \SHIFTSTATE \MOUSETIMERTEMP))
(CONSTANTS NRINGINDEXWORDS)
(CONSTANTS (\SYSBUFFER.FIRST (UNFOLD NRINGINDEXWORDS BYTESPERWORD))
(\SYSBUFFER.LAST (IPLUS \SYSBUFFER.FIRST (SUB1 \SYSBUFSIZE]
(DECLARE: EVAL@COMPILE (VARS \KEYNAMES))
(VARS \ORIGKEYACTIONS \DLIONKEYACTIONS \DLIONOSDKEYACTIONS \DORADOKEYACTIONS
\DOVEKEYACTIONS \DOVEOSDKEYACTIONS)
(INITVARS (\KEYBOARD.META 256)
(\MODIFIED.KEYACTIONS))
(GLOBALVARS \SYSBUFFER \LONGSYSBUF \INTERRUPTSTATE \MODIFIED.KEYACTIONS \RCLKSECOND
\LASTUSERACTION \MOUSECHORDTICKS \LASTKEYSTATE \KEYBOARDEVENTQUEUE \KEYBUFFERING
\CURRENTKEYACTION \DEFAULTKEYACTION \TIMER.INTERRUPT.PENDING \ORIGKEYACTIONS
\KEYBOARD.META \MOUSECHORDMILLISECONDS \DORADOKEYACTIONS \DLIONKEYACTIONS
\DLIONOSDKEYACTIONS \DOVEKEYACTIONS \DOVEOSDKEYACTIONS))
(COMS (* Key interpretation)
(FNS KEYACTION KEYACTIONTABLE \KEYACTION1 KEYDOWNP \KEYNAMETONUMBER MODIFY.KEYACTIONS
METASHIFT SHIFTDOWNP)
(* To support office style 1108 & 1186 keyboards)
(FNS SETUP.OFFICE.KEYBOARD)
(MACROS \KEYNAMETONUMBER \TEMPCOPYTIMER)
(EXPORT (MACROS XKEYDOWNP KEYDOWNP KEYDOWNP1 \NEWKEYDOWNP)))
(COMS (* A raw keyboard device/stream)
(FNS \INIT.KEYBOARD.STREAM)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (\INIT.KEYBOARD.STREAM)))
(EXPORT (GLOBALVARS \KEYBOARD.DEVICE \KEYBOARD.STREAM)))
(COMS (* Hook for a periodic interrupt)
(FNS \DOBUFFEREDTRANSITIONS \TIMER.INTERRUPTFRAME \PERIODIC.INTERRUPTFRAME)
(INITVARS (\KEYBUFFERING)
(\PERIODIC.INTERRUPT)
(\TIMER.INTERRUPT.PENDING)
(\PERIODIC.INTERRUPT.FREQUENCY 77)))
(LOCALVARS . T)
[COMS (* cursor and mouse related functions.)
(FNS \HARDCURSORUP \HARDCURSORPOSITION \HARDCURSORDOWN)
(FNS CURSOR.INIT \CURSORDESTINATION \SOFTCURSORUP \SOFTCURSORUPCURRENT
\SOFTCURSORPOSITION \SOFTCURSORDOWN CURSORPROP GETCURSORPROP PUTCURSORPROP
\CURSORBITSPERPIXEL \CURSORIMAGEPROPNAME \CURSORMASKPROPNAME)
(FNS CURSORCREATE CURSOR \CURSORUP \CURSORPOSITION \CURSORDOWN ADJUSTCURSORPOSITION
CURSORPOSITION CURSORSCREEN CURSOREXIT FLIPCURSOR FLIPCURSORBAR LASTMOUSEX
LASTMOUSEY CREATEPOSITION POSITIONP CURSORHOTSPOT)
(PROPS (CURSORPROP ARGNAMES))
(INITVARS (\CURSORHOTSPOTX 0)
(\CURSORHOTSPOTY 0)
(\CURRENTCURSOR NIL)
(\SOFTCURSORWIDTH NIL)
(\SOFTCURSORHEIGHT NIL)
(\SOFTCURSORP NIL)
(\SOFTCURSORUPP NIL)
(\SOFTCURSORUPBM NIL)
(\SOFTCURSORDOWNBM NIL)
(\SOFTCURSORBBT1 NIL)
(\SOFTCURSORBBT2 NIL)
(\SOFTCURSORBBT3 NIL)
(\SOFTCURSORBBT4 NIL)
(\SOFTCURSORBBT5 NIL)
(\SOFTCURSORBBT6 NIL)
(\CURSORSCREEN NIL)
(\CURSORDESTINATION NIL)
(\CURSORDESTHEIGHT 808)
(\CURSORDESTWIDTH 1024)
(\CURSORDESTRASTERWIDTH 64)
(\CURSORDESTLINE 0)
(\CURSORDESTLINEBASE NIL))
(GLOBALVARS \CURSORHOTSPOTX \CURSORHOTSPOTY \CURRENTCURSOR \SOFTCURSORWIDTH
\SOFTCURSORHEIGHT \SOFTCURSORP \SOFTCURSORUPP \SOFTCURSORUPBM \SOFTCURSORDOWNBM
\SOFTCURSORBBT1 \SOFTCURSORBBT2 \SOFTCURSORBBT3 \SOFTCURSORBBT4 \SOFTCURSORBBT5
\SOFTCURSORBBT6 \CURSORDESTINATION \CURSORDESTHEIGHT \CURSORDESTWIDTH
\CURSORDESTRASTERWIDTH \CURSORDESTLINE \CURSORDESTLINEBASE)
(FNS GETMOUSESTATE \EVENTKEYS)
[EXPORT (CONSTANTS (HARDCURSORHEIGHT 16)
(HARDCURSORWIDTH 16))
(DECLARE: EVAL@COMPILE (ADDVARS (GLOBALVARS LASTMOUSEX LASTMOUSEY LASTSCREEN
LASTMOUSEBUTTONS LASTMOUSETIME
LASTKEYBOARD]
(DECLARE: DONTCOPY (EXPORT (MACROS \SETMOUSEXY))
(MACROS \XMOUSECOORD \YMOUSECOORD))
(DECLARE: DONTEVAL@LOAD DOCOPY (P (MOVD (QUOTE CURSOR)
(QUOTE SETCURSOR))
(MOVD (QUOTE \CURSORPOSITION)
(QUOTE \SETCURSORPOSITION)))
(VARS (\SFPosition (CREATEPOSITION]
[COMS (DECLARE: DONTCOPY (RECORDS KEYBOARDEVENT)
(CONSTANTS (\KEYBOARDEVENT.FIRST NRINGINDEXWORDS)
\KEYBOARDEVENT.SIZE
(\KEYBOARDEVENT.LAST (PLUS \KEYBOARDEVENT.FIRST (TIMES
\KEYBOARDEVENT.SIZE
383]
(COMS (FNS MACHINETYPE SETMAINTPANEL)
(* DLion beeper)
(FNS BEEPON BEEPOFF))
(EXPORT (GLOBALVARS \EM.MOUSEX \EM.MOUSEY \EM.CURSORX \EM.CURSORY \EM.UTILIN \EM.REALUTILIN
\EM.KBDAD0 \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3 \EM.KBDAD4 \EM.KBDAD5
\EM.DISPINTERRUPT \EM.DISPLAYHEAD \EM.CURSORBITMAP \MACHINETYPE
\DEFAULTKEYACTION \CURRENTKEYACTION \PERIODIC.INTERRUPT
\PERIODIC.INTERRUPT.FREQUENCY))
(FNS WITHOUT-INTERRUPTS)
(COMS (* Compile locked fns together for locality)
(BLOCKS (NIL FLIPCURSORBAR \KEYHANDLER \KEYHANDLER1 \TRACKCURSOR
\PERIODIC.INTERRUPTFRAME \TIMER.INTERRUPTFRAME \DOBUFFEREDTRANSITIONS
\DOTRANSITIONS \DECODETRANSITION \EVENTKEYS \HARDCURSORUP
\HARDCURSORPOSITION \HARDCURSORDOWN \SOFTCURSORUP \SOFTCURSORUPCURRENT
\SOFTCURSORPOSITION \SOFTCURSORDOWN)))
[DECLARE: DONTCOPY
(ADDVARS [INEWCOMS (ALLOCAL (ADDVARS (LOCKEDFNS FLIPCURSORBAR \SETIOPOINTERS
\KEYHANDLER \KEYHANDLER1 \CONTEXTAPPLY
\LOCKPAGES \DECODETRANSITION \SMASHLINK
\INCUSECOUNT LLSH \MAKEFREEBLOCK
\DECUSECOUNT \MAKENUMBER \ADDBASE
\PERIODIC.INTERRUPTFRAME
\DOBUFFEREDTRANSITIONS
\TIMER.INTERRUPTFRAME \TRACKCURSOR
\HARDCURSORUP \HARDCURSORPOSITION
\HARDCURSORDOWN \SOFTCURSORUP
\SOFTCURSORUPCURRENT \SOFTCURSORPOSITION
\SOFTCURSORDOWN \SOFTCURSORPILOTBITBLT)
(LOCKEDVARS \InterfacePage \CURSORHOTSPOTX
\CURSORHOTSPOTY \CURRENTCURSOR
\SOFTCURSORWIDTH \SOFTCURSORHEIGHT
\SOFTCURSORP \SOFTCURSORUPP \SOFTCURSORUPBM
\SOFTCURSORDOWNBM \SOFTCURSORBBT1
\SOFTCURSORBBT2 \SOFTCURSORBBT3
\SOFTCURSORBBT4 \SOFTCURSORBBT5
\SOFTCURSORBBT6 \CURSORDESTINATION
\CURSORDESTHEIGHT \CURSORDESTWIDTH
\CURSORDESTRASTERWIDTH \CURSORDESTLINE
\CURSORDESTLINEBASE \PENDINGINTERRUPT
\PERIODIC.INTERRUPT
\PERIODIC.INTERRUPT.FREQUENCY
\LASTUSERACTION \MOUSECHORDTICKS
\KEYBOARDEVENTQUEUE \KEYBUFFERING
SCREENWIDTH SCREENHEIGHT
\TIMER.INTERRUPT.PENDING \EM.MOUSEX
\EM.MOUSEY \EM.CURSORX \EM.CURSORY
\EM.UTILIN \EM.REALUTILIN \EM.KBDAD0
\EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3
\EM.DISPINTERRUPT \EM.CURSORBITMAP
\EM.KBDAD4 \EM.KBDAD5 \MISCSTATS \RCLKSECOND
]
(RDCOMS (FNS \SETIOPOINTERS]
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML WITHOUT-INTERRUPTS
)
(LAMA CURSORPROP
METASHIFT
MOUSECHORDWAIT])
(* Access to keyboard)
(DEFINEQ
(BKSYSCHARCODE
(LAMBDA (CHAR) (* rrb "30-Dec-83 11:56")
(OR (\PUTSYSBUF CHAR)
(PROGN (SETQ \LONGSYSBUF (NCONC \LONGSYSBUF (bind C while (SETQ C (
\GETREALSYSBUF))
collect C)))
(\PUTSYSBUF CHAR)))))
(\CLEARSYSBUF
(LAMBDA (ALLFLG) (* mpl "27-Jun-85 20:04")
(DECLARE (GLOBALVARS \PROCESSES))
(COND
((OR ALLFLG (TTY.PROCESSP))
(SETQ \LONGSYSBUF)
(replace (RING READ) of \SYSBUFFER with 0)))
(COND
(ALLFLG (for PROC in \PROCESSES do (replace PROCTYPEAHEAD of PROC with NIL)))
((THIS.PROCESS)
(replace PROCTYPEAHEAD of (THIS.PROCESS) with NIL)))))
(\GETKEY
(LAMBDA NIL (* lmm "18-Apr-85 00:07")
(DECLARE (GLOBALVARS \KEYBOARDWAIT1 \KEYBOARDWAIT2))
(COND
((AND (THIS.PROCESS)
(fetch PROCTYPEAHEAD of (THIS.PROCESS)))
(pop (fetch PROCTYPEAHEAD of (THIS.PROCESS))))
(T (WAIT.FOR.TTY)
(OR (\GETSYSBUF)
(GLOBALRESOURCE (\KEYBOARDWAITBOX) (* Busy-wait loop that gets next character)
(\CLOCK0 \KEYBOARDWAITBOX)
(bind C
do (COND
((SETQ C (\GETSYSBUF))
(\BOXIPLUS (LOCF (fetch KEYBOARDWAITTIME of
\MISCSTATS))
(CLOCKDIFFERENCE \KEYBOARDWAITBOX))
(RETURN C)))
(\TTYBACKGROUND)
(\WAIT.FOR.TTY))))))))
(\NSYSBUFCHARS
(LAMBDA NIL (* JonL " 7-May-84 01:50")
(* Tells how many characters can be \GETSYSBUFed.
Used by \SAVESYSBUF.)
(IPLUS (LENGTH \LONGSYSBUF)
(PROG ((R (fetch (RING READ) of \SYSBUFFER))
(W (fetch (RING WRITE) of \SYSBUFFER)))
(RETURN (COND
((EQ 0 R)
0)
((IGREATERP W R)
(IDIFFERENCE W R))
(T (IDIFFERENCE W (IDIFFERENCE R \SYSBUFSIZE)))))))))
(\SAVESYSBUF
(LAMBDA NIL (* JonL " 7-May-84 01:50")
(DECLARE (GLOBALVARS \SAVEDSYSBUFFER))
(PROG (TA (BUF \SAVEDSYSBUFFER)
(NC (\NSYSBUFCHARS))
(J 0))
(COND
((TTY.PROCESSP)
(COND
((AND (THIS.PROCESS)
(SETQ TA (fetch PROCTYPEAHEAD of (THIS.PROCESS))))
(replace PROCTYPEAHEAD of (THIS.PROCESS) with NIL)
(add NC (LENGTH TA))
(COND
((IGREATERP NC (NCHARS BUF))
(SETQ BUF (ALLOCSTRING NC))))
(for CH in TA do (RPLCHARCODE BUF (add J 1)
CH)))
((IGREATERP NC (NCHARS BUF))
(SETQ BUF (ALLOCSTRING NC))))
(for I from (ADD1 J) to NC
do
(* Test on J means that we'll ignore extra chars typed since we got the length. Test on \GETSYSBUF so we don't get
screwed if buffer gets cleared while during this loop)
(RPLCHARCODE BUF I (OR (\GETSYSBUF)
(PROGN (SETQ NC (SUB1 I))
(RETURN)))))))
(RETURN (AND (NOT (EQ 0 NC))
(SUBSTRING BUF 1 NC))))))
(\SYSBUFP
(LAMBDA NIL (* JonL " 7-May-84 01:52")
(OR (AND (TTY.PROCESSP)
(OR \LONGSYSBUF (NOT (EQ 0 (fetch (RING READ) of \SYSBUFFER)))))
(AND (THIS.PROCESS)
(fetch PROCTYPEAHEAD of (THIS.PROCESS))))))
(\GETSYSBUF
(LAMBDA NIL (* lmm " 9-JUL-83 00:56")
(OR (AND \LONGSYSBUF (pop \LONGSYSBUF))
(\GETREALSYSBUF))))
(\PUTSYSBUF
(LAMBDA (CHAR) (* rmk: "27-Nov-84 17:51")
(PROG ((R (fetch (RING READ) of \SYSBUFFER))
(W (fetch (RING WRITE) of \SYSBUFFER)))
(RETURN (COND
((EQ R W) (* Full)
NIL)
(T (\PUTBASEFAT \SYSBUFFER W CHAR)
(AND (EQ 0 R)
(replace (RING READ) of \SYSBUFFER with W))
(* Return random non-NIL value to indicate success for
BKSYSBUF)
(replace (RING WRITE) of \SYSBUFFER with (COND
((EQ \SYSBUFFER.LAST W)
\SYSBUFFER.FIRST)
(T (ADD1 W))))
T))))))
(\PEEKSYSBUF
(LAMBDA (STREAM) (* bvm: " 8-Feb-85 17:50")
(PROG (R)
WAIT(until (\SYSBUFP) do (BLOCK))
(RETURN (if (TTY.PROCESSP)
then (if \LONGSYSBUF
then (CAR \LONGSYSBUF)
elseif (NEQ (SETQ R (fetch (RING READ) of \SYSBUFFER))
0)
then (* Here's the vanilla case)
(\GETBASEFAT \SYSBUFFER R)
else (* Foo an interrupt could have sneaked in here and
gobbled down the remaining characters)
(GO WAIT))
elseif (THIS.PROCESS)
then (CAR (fetch PROCTYPEAHEAD of (THIS.PROCESS)))
else (SHOULDNT))))))
)
(RPAQ? \LONGSYSBUF )
(RPAQ? \\KEYBOARDWAITBOX.GLOBALRESOURCE )
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTDEF (QUOTE \KEYBOARDWAITBOX)
(QUOTE RESOURCES)
(QUOTE (NEW (CREATECELL \FIXP]
)
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(RPAQQ \SYSBUFSIZE 200)
(CONSTANTS (\SYSBUFSIZE 200))
)
(DECLARE: EVAL@COMPILE
[PUTPROPS \GETREALSYSBUF MACRO
(NIL (PROG ((R (fetch (RING READ)
of \SYSBUFFER)))
(RETURN (AND (NOT (EQ 0 R))
(PROG1 (\GETBASEFAT \SYSBUFFER R)
(AND [EQ (fetch (RING WRITE)
of \SYSBUFFER)
(replace (RING READ)
of \SYSBUFFER with (COND ((EQ \SYSBUFFER.LAST R
)
\SYSBUFFER.FIRST)
(T (ADD1 R]
(replace (RING READ)
of \SYSBUFFER with 0]
)
)
(DECLARE: DOCOPY DONTEVAL@LOAD
(* Here because it must be done in init before PROC loaded)
(MOVD? (QUOTE NILL)
(QUOTE CARET))
)
(* Key handler)
(DEFINEQ
(\KEYBOARDINIT
(LAMBDA NIL (* lmm "23-May-85 15:57")
(DECLARE (GLOBALVARS \SAVEDSYSBUFFER)) (* Sets up keyboard decoding tables.)
(SETQ \CURRENTKEYACTION (SETQ \DEFAULTKEYACTION (create KEYACTION)))
(for X in \ORIGKEYACTIONS do (KEYACTION (CAR X)
(CDR X)))
(SETQ \INTERRUPTSTATE (\ALLOCLOCKED 2))
(PROGN (SETQ \SYSBUFFER (\ALLOCBLOCK (FOLDHI (ADD1 \SYSBUFFER.LAST)
WORDSPERCELL)))
(replace (RING READ) of \SYSBUFFER with 0)
(replace (RING WRITE) of \SYSBUFFER with \SYSBUFFER.FIRST))
(SETQ \SAVEDSYSBUFFER (ALLOCSTRING \SYSBUFSIZE NIL NIL T))
(SETQ \LASTUSERACTION (LOCF (fetch LASTUSERACTION of \MISCSTATS)))
(PROGN (SETQ \KEYBOARDEVENTQUEUE (\ALLOCLOCKED (FOLDHI (PLUS \KEYBOARDEVENT.LAST
\KEYBOARDEVENT.SIZE)
WORDSPERCELL)))
(replace (RING READ) of \KEYBOARDEVENTQUEUE with 0)
(replace (RING WRITE) of \KEYBOARDEVENTQUEUE with \KEYBOARDEVENT.FIRST))
(SETQ \LASTKEYSTATE (create KEYBOARDEVENT))
(SETQ \SHIFTSTATE (create SHIFTSTATE))
(SETQ \MOUSETIMERTEMP (SETUPTIMER 0 NIL (QUOTE TICKS)))
(MOUSECHORDWAIT \MOUSECHORDMILLISECONDS)
(\KEYBOARDON)))
(\KEYBOARDEVENTFN
(LAMBDA (FDEV EVENT EXTRA) (* jds "11-Nov-85 00:30")
(DECLARE (GLOBALVARS \KEYBOARD.BEFORETYPE \DORADOKEYACTIONS \DLIONKEYACTIONS))
(SELECTQ EVENT
((BEFORELOGOUT BEFOREMAKESYS BEFORESYSOUT BEFORESAVEVM)
(SETQ \KEYBOARD.BEFORETYPE \MACHINETYPE))
((AFTERLOGOUT AFTERMAKESYS AFTERSYSOUT AFTERSAVEVM)
(* Restarting a world. If we changed machines, fix up
the key actions to match the new machine.)
(COND
((NEQ \MACHINETYPE \KEYBOARD.BEFORETYPE)
(* Changed machines. Change Keyactions.)
(for X in (SELECTC \MACHINETYPE
(\DORADO \DORADOKEYACTIONS)
(\DANDELION \DLIONKEYACTIONS)
(\DAYBREAK (* Moving to a daybreak. Need to distinguish among the
various kinds of keyboard.)
(* For now, we only distinguish between the office keyboards (1 = US, 2 = Euro, 3 = Japanese, 4 = ADM-3), and some
yet-to-be-determined Lisp-keyboard number)
(COND
((ILEQ (\DoveMisc.ReadKeyboardType)
4)
(* It's an office keyboard.
Set it up right!)
(APPEND \DOVEKEYACTIONS
\DOVEOSDKEYACTIONS))
(T
(* Lisp keyboard. Leave the Dove keyactions as they
were.)
\DOVEKEYACTIONS)))
NIL)
do (KEYACTION (CAR X)
(CDR X)
\DEFAULTKEYACTION))
(MOUSECHORDWAIT (MOUSECHORDWAIT)))))
((AFTERDOSAVEVM AFTERDOMAKESYS)
NIL)
NIL)))
(\ALLOCLOCKED
(LAMBDA (NCELLS) (* lmm "20-Apr-85 13:08")
(* allocate a block of NCELLS cells and lock it)
(PROG ((BLOCK (\ALLOCBLOCK NCELLS NIL (IMIN NCELLS CELLSPERPAGE))))
(\LOCKCELL BLOCK (FOLDHI (IPLUS (fetch (POINTER WORDINPAGE) of BLOCK)
(UNFOLD NCELLS WORDSPERCELL))
WORDSPERPAGE))
(RETURN BLOCK))))
(\SETIOPOINTERS
(LAMBDA NIL (* bvm: " 9-Oct-85 11:49")
(SELECTC (SETTOPVAL (QUOTE \MACHINETYPE)
(fetch MachineType of \InterfacePage))
((LIST \DOLPHIN \DORADO)
(SETTOPVAL (QUOTE \EM.MOUSEX)
(EMADDRESS MOUSEX.EM))
(SETTOPVAL (QUOTE \EM.MOUSEY)
(EMADDRESS MOUSEY.EM))
(SETTOPVAL (QUOTE \EM.CURSORX)
(EMADDRESS CURSORX.EM))
(SETTOPVAL (QUOTE \EM.CURSORY)
(EMADDRESS CURSORY.EM))
(SETTOPVAL (QUOTE \EM.REALUTILIN)
(EMADDRESS UTILIN.EM))
(SETTOPVAL (QUOTE \EM.KBDAD0)
(EMADDRESS KBDAD0.EM))
(SETTOPVAL (QUOTE \EM.KBDAD1)
(EMADDRESS KBDAD1.EM))
(SETTOPVAL (QUOTE \EM.KBDAD2)
(EMADDRESS KBDAD2.EM))
(SETTOPVAL (QUOTE \EM.KBDAD3)
(EMADDRESS KBDAD3.EM))
(SETTOPVAL (QUOTE \EM.KBDAD4)
(LOCF (fetch FAKEKBDAD4 of \InterfacePage)))
(\PUTBASE \EM.KBDAD4 0 ALLUP)
(SETTOPVAL (QUOTE \EM.KBDAD5)
(LOCF (fetch FAKEKBDAD5 OF \InterfacePage)))
(\PUTBASE \EM.KBDAD5 0 ALLUP)
(SETTOPVAL (QUOTE \EM.DISPINTERRUPT)
(EMADDRESS DISPINTERRUPT.EM))
(SETTOPVAL (QUOTE \EM.CURSORBITMAP)
(EMADDRESS CURSORBITMAP.EM))
(SETTOPVAL (QUOTE \EM.DISPLAYHEAD)
(EMADDRESS DCB.EM))
(SETTOPVAL (QUOTE SCREENWIDTH)
(UNFOLD (fetch ScreenWidth of \InterfacePage)
BITSPERWORD)))
(\DANDELION (SETTOPVAL (QUOTE \EM.MOUSEX)
(fetch DLMOUSEXPTR of \IOPAGE))
(SETTOPVAL (QUOTE \EM.MOUSEY)
(fetch DLMOUSEYPTR of \IOPAGE))
(SETTOPVAL (QUOTE \EM.CURSORX)
(fetch DLCURSORXPTR of \IOPAGE))
(SETTOPVAL (QUOTE \EM.CURSORY)
(fetch DLCURSORYPTR of \IOPAGE))
(PROGN (SETTOPVAL (QUOTE \EM.REALUTILIN)
(fetch DLUTILINPTR of \IOPAGE))
(* Where the hardware bits live, vs.
where the Lisp software sees them after
reinterpretation by keyhandler)
)
(SETTOPVAL (QUOTE \EM.KBDAD0)
(fetch DLKBDAD0PTR of \IOPAGE))
(SETTOPVAL (QUOTE \EM.KBDAD1)
(fetch DLKBDAD1PTR of \IOPAGE))
(SETTOPVAL (QUOTE \EM.KBDAD2)
(fetch DLKBDAD2PTR of \IOPAGE))
(SETTOPVAL (QUOTE \EM.KBDAD3)
(fetch DLKBDAD3PTR of \IOPAGE))
(SETTOPVAL (QUOTE \EM.KBDAD4)
(fetch DLKBDAD4PTR of \IOPAGE))
(SETTOPVAL (QUOTE \EM.KBDAD5)
(fetch DLKBDAD5PTR of \IOPAGE))
(SETTOPVAL (QUOTE \EM.DISPINTERRUPT)
(fetch DLDISPINTERRUPTPTR of \IOPAGE))
(SETTOPVAL (QUOTE \EM.CURSORBITMAP)
(fetch DLCURSORBITMAPPTR of \IOPAGE))
(SETTOPVAL (QUOTE \EM.DISPLAYHEAD)
NIL)
(SETTOPVAL (QUOTE SCREENWIDTH)
1024))
(\DAYBREAK (PROG ((KBDBASE (\DoveMisc.GetKBDBase)))
(SETTOPVAL (QUOTE \EM.KBDAD0)
(\ADDBASE KBDBASE 1))
(SETTOPVAL (QUOTE \EM.KBDAD1)
(\ADDBASE KBDBASE 2))
(SETTOPVAL (QUOTE \EM.KBDAD2)
(\ADDBASE KBDBASE 3))
(SETTOPVAL (QUOTE \EM.KBDAD3)
(\ADDBASE KBDBASE 4))
(SETTOPVAL (QUOTE \EM.KBDAD4)
(\ADDBASE KBDBASE 5))
(SETTOPVAL (QUOTE \EM.KBDAD5)
(\ADDBASE KBDBASE 6))
(SETTOPVAL (QUOTE \EM.MOUSEX)
(\DoveMisc.GetMouseXBase))
(SETTOPVAL (QUOTE \EM.MOUSEY)
(\DoveMisc.GetMouseYBase))
(SETTOPVAL (QUOTE \EM.CURSORBITMAP)
(\DoveDisplay.GetCursorBitmapBase))
(* These three set this way to prevent address faults)
(SETTOPVAL (QUOTE \EM.DISPINTERRUPT)
(fetch DLDISPINTERRUPTPTR of \IOPAGE))
(SETTOPVAL (QUOTE \EM.CURSORX)
(fetch DLCURSORXPTR of \IOPAGE))
(SETTOPVAL (QUOTE \EM.CURSORY)
(fetch DLCURSORYPTR of \IOPAGE))
(PROGN (SETTOPVAL (QUOTE \EM.REALUTILIN)
KBDBASE)
(* Where the hardware bits live, vs.
where the Lisp software sees them after
reinterpretation by keyhandler)
)
(SETTOPVAL (QUOTE SCREENWIDTH)
(\DoveDisplay.ScreenWidth))))
(RAID))
(SETTOPVAL (QUOTE \EM.UTILIN)
(LOCF (fetch (IFPAGE FAKEMOUSEBITS) of \InterfacePage)))))
(\KEYBOARDOFF
(LAMBDA NIL (* lmm "30-MAR-83 20:40")
(\PUTBASE \EM.DISPINTERRUPT 0 (LOGAND (LOGXOR 65535 \LispKeyMask)
(\GETBASE \EM.DISPINTERRUPT 0)))))
(\KEYBOARDON
(LAMBDA (NOCHECK) (* lmm "30-MAR-83 20:39")
(\SETIOPOINTERS)
(\PUTBASE \EM.DISPINTERRUPT 0 (LOGOR \LispKeyMask (\GETBASE \EM.DISPINTERRUPT 0)))))
(\KEYHANDLER
(LAMBDA NIL (* lmm "30-MAR-83 20:40")
(\KEYHANDLER1)))
(\KEYHANDLER1
(LAMBDA NIL (* bvm: " 9-Oct-85 12:46")
(PROG ((OLD0 ALLUP)
(OLD1 ALLUP)
(OLD2 ALLUP)
(OLD3 ALLUP)
(OLD4 ALLUP)
(OLD5 ALLUP)
(OLDU ALLUP)
(OLDFAKEU ALLUP)
(LOOPCNT 10)
(PERIODCNT 60)
(MOUSESTATE \DLMOUSE.UP)
(MOUSETIMER (LOCF (fetch DLMOUSETIMER of \MISCSTATS)))
(MOUSETEMP (LOCF (fetch DLMOUSETEMP of \MISCSTATS)))
CURSORX CURSORY YHOT)
(SETQ \KEYBUFFERING NIL)
(replace (RING READ) of \KEYBOARDEVENTQUEUE with 0)
LP (\CONTEXTSWITCH \KbdFXP)
(COND
(\PERIODIC.INTERRUPT (* eventually can be replaced with general timer
mechanism)
(COND
((IGREATERP PERIODCNT 0)
(* Continue counting down to zero)
(SETQ PERIODCNT (SUB1 PERIODCNT)))
((\CAUSEINTERRUPT \KbdFXP (FUNCTION \PERIODIC.INTERRUPTFRAME)
) (* When we've counted down, then keep trying to cause
the interrupt, and reset the counter when it finally
happens)
(SETQ PERIODCNT (SUB1 (OR \PERIODIC.INTERRUPT.FREQUENCY
1)))))))
(COND
((OR (NEQ (\GETBASE \EM.MOUSEX 0)
CURSORX)
(NEQ (\GETBASE \EM.MOUSEY 0)
CURSORY))
(\TRACKCURSOR (SETQ CURSORX (\GETBASE \EM.MOUSEX 0))
(SETQ CURSORY (\GETBASE \EM.MOUSEY 0)))))
(COND
((OR (COND
((OR (NEQ OLDU (\GETBASE \EM.REALUTILIN 0))
(COND
((AND (EQ MOUSESTATE \DLMOUSE.WAITING)
(IGREATERP (\BOXIDIFFERENCE (\RCLK MOUSETEMP)
MOUSETIMER)
0)) (* Timer expired on seeing both left and right down,
so set state to normal)
(SETQ MOUSESTATE \DLMOUSE.NORMAL)
T)))
(SETQ MOUSESTATE (\DOMOUSECHORDING (SETQ OLDU (\GETBASE
\EM.REALUTILIN 0))
MOUSESTATE))
(NEQ OLDFAKEU (\GETBASE \EM.UTILIN 0))))
(NEQ OLD0 (\GETBASE \EM.KBDAD0 0))
(NEQ OLD1 (\GETBASE \EM.KBDAD1 0))
(NEQ OLD2 (\GETBASE \EM.KBDAD2 0))
(NEQ OLD3 (\GETBASE \EM.KBDAD3 0))
(NEQ OLD4 (\GETBASE \EM.KBDAD4 0))
(NEQ OLD5 (\GETBASE \EM.KBDAD5 0)))
(COND
((EQ 0 (LOGAND (\GETBASE \EM.KBDAD2 0)
2114)) (* Ctrl-shift-DEL panic interrupt -- switch to
TeleRaid immediately)
(swap (fetch (IFPAGE TELERAIDFXP) of \InterfacePage)
(fetch (IFPAGE KbdFXP) of \InterfacePage))
(\KEYBOARDOFF)
(SETQ OLD2 (\GETBASE \EM.KBDAD2 0))
(GO LP)))
(PROG ((W (fetch (RING WRITE) of \KEYBOARDEVENTQUEUE))
(R (fetch (RING READ) of \KEYBOARDEVENTQUEUE))
WPTR)
(COND
((EQ R W) (* eventqueue full!)
(RETURN)))
(SETQ WPTR (\ADDBASE \KEYBOARDEVENTQUEUE W))
(\RCLK (LOCF (fetch TIME of WPTR)))
(with KEYBOARDEVENT WPTR (PROGN (SETQ W0 (SETQ OLD0 (\GETBASE
\EM.KBDAD0 0)))
(SETQ W1 (SETQ OLD1 (\GETBASE
\EM.KBDAD1 0)))
(SETQ W2 (SETQ OLD2 (\GETBASE
\EM.KBDAD2 0)))
(SETQ W3 (SETQ OLD3 (\GETBASE
\EM.KBDAD3 0)))
(SETQ W4 (SETQ OLD4 (\GETBASE
\EM.KBDAD4 0)))
(SETQ W5 (SETQ OLD5 (\GETBASE
\EM.KBDAD5 0)))
(SETQ WU (SETQ OLDFAKEU
(\GETBASE \EM.UTILIN 0)))))
(COND
((EQ R 0) (* Queue was empty)
(replace (RING READ) of \KEYBOARDEVENTQUEUE with W)))
(replace (RING WRITE) of \KEYBOARDEVENTQUEUE
with (COND
((IGEQ W \KEYBOARDEVENT.LAST)
\KEYBOARDEVENT.FIRST)
(T (IPLUS W \KEYBOARDEVENT.SIZE)))))
(OR \KEYBUFFERING (SETQ \KEYBUFFERING T))))
(COND
(\KEYBUFFERING (COND
((EQ \KEYBUFFERING T)
(COND
((\CAUSEINTERRUPT \KbdFXP (FUNCTION \DOBUFFEREDTRANSITIONS))
(SETQ \KEYBUFFERING (QUOTE STARTED))
(* don't call until \DOBUFFEREDTRANSITIONS is done)
)))))
(T (COND
(\PENDINGINTERRUPT (COND
((\CAUSEINTERRUPT \KbdFXP (FUNCTION \INTERRUPTFRAME))
(SETQ \PENDINGINTERRUPT)))))))
(COND
((ILEQ (SETQ LOOPCNT (SUB1 LOOPCNT))
0) (* Only do this once in a while)
(SETQ LOOPCNT (COND
((\UPDATETIMERS) (* Timer was updated, so do it next time around, too,
in case we just came back from RAID or other bcpl
code)
1)
(T 20)))))
(COND
((AND NIL \TIMER.INTERRUPT.PENDING (IGREATERP (\BOXIDIFFERENCE
(\RCLK (LOCF (fetch DLMOUSETEMP
of \MISCSTATS)))
(LOCF (fetch DLMOUSETIMER
of \MISCSTATS)))
0)
(COND
((EQ \TIMER.INTERRUPT.PENDING (QUOTE \MOUSECHANGE))
(SETQ OLDU NIL)
T)
(T (\CAUSEINTERRUPT \KbdFXP (FUNCTION \TIMER.INTERRUPTFRAME)))))
(SETQ \TIMER.INTERRUPT.PENDING)))
(GO LP))))
(\RESETKEYBOARD
(LAMBDA NIL (* bvm: "21-Nov-85 16:10")
(\SETIOPOINTERS) (* Called with lisp keyboard disabled whenever Lisp is
resumed from bcpl logout or copysys.)
(SETQ \KEYBUFFERING NIL)
(COND
((OR (EQ \MACHINETYPE \DANDELION)
(EQ \MACHINETYPE \DAYBREAK)) (* Initialize fake mouse bits to all up)
(\PUTBASE \EM.UTILIN 0 ALLUP)))
(with KEYBOARDEVENT \LASTKEYSTATE (SETQ W0 (\GETBASE \EM.KBDAD0 0))
(SETQ W1 (\GETBASE \EM.KBDAD1 0))
(SETQ W2 (\GETBASE \EM.KBDAD2 0))
(SETQ W3 (\GETBASE \EM.KBDAD3 0))
(SETQ W4 (\GETBASE \EM.KBDAD4 0))
(SETQ W5 (\GETBASE \EM.KBDAD5 0))
(SETQ WU (\GETBASE \EM.REALUTILIN 0))
(SETQ LOCK (XKEYDOWNP (QUOTE LOCK)))
(SETQ 1SHIFT NIL)
(SETQ 2SHIFT NIL)
(SETQ CTRL NIL)
(SETQ META NIL)
(SETQ FONT NIL)
(SETQ USERMODE1 NIL)
(SETQ USERMODE2 NIL)
(SETQ USERMODE3 NIL)
(SETQ MOUSESTATE \DLMOUSE.UP))
(SETQ \TIMER.INTERRUPT.PENDING)
(replace (RING READ) of \KEYBOARDEVENTQUEUE with 0)
(replace (RING READ) of \SYSBUFFER with 0)
(SETQ \LONGSYSBUF)
(\DAYTIME0 \LASTUSERACTION)
(\KEYBOARDON)))
(\DOMOUSECHORDING
(LAMBDA (REALUTILIN STATE) (* bvm: " 9-Oct-85 11:24")
(* Handles mouse transitions on a DLion. REALUTILIN is the actual util word from the processor.
STATE is our internal state. Sets contents of \EM.UTILIN to reflect the virtual mouse state, which may contain a
middle mouse button even where there is only a two-button mouse. Returns new state)
(PROG (LRSTATE)
(COND
((OR (NULL \MOUSECHORDTICKS)
(EQ (SETQ LRSTATE (LOGXOR (LOGAND REALUTILIN \MOUSE.ALLBITS)
\MOUSE.ALLBITS))
0)) (* Not interpreting chording, or both LEFT and RIGHT
are up -- real state and virtual state the same)
(SETQ STATE \DLMOUSE.UP))
(T (* Either L or R or both are down, so have to decide
about Middle)
(SELECTC STATE
((LIST \DLMOUSE.UP \DLMOUSE.WAITING)
(SETQ REALUTILIN (LOGOR REALUTILIN \MOUSE.LRBIT))
(* Turn off the L and/or R bits)
(COND
((EQ LRSTATE \MOUSE.LRBIT)
(* Both L and R down at once, interpret as MIDDLE
without waiting)
(SETQ REALUTILIN (LOGAND (LOGXOR ALLUP \MOUSE.MIDDLEBIT)
REALUTILIN))
(SETQ STATE \DLMOUSE.MIDDLE))
((NEQ STATE \DLMOUSE.WAITING)
(* Only one of L and R down.
Set timer, and ignore the down bit for now)
(\BOXIPLUS (\RCLK (LOCF (fetch DLMOUSETIMER of \MISCSTATS)))
\MOUSECHORDTICKS)
(SETQ STATE \DLMOUSE.WAITING))))
(\DLMOUSE.MIDDLE (* State is middle and at least one of L and R is
still down, so consider it to be still only middle)
(SETQ REALUTILIN (LOGAND (LOGXOR ALLUP
\MOUSE.MIDDLEBIT)
(LOGOR REALUTILIN
\MOUSE.LRBIT)))
(SELECTC LRSTATE
(\MOUSE.LEFTBIT
(* Right came up. Henceforth treat right
transparently)
(SETQ STATE
\DLMOUSE.MIDDLE&RIGHT))
(\MOUSE.RIGHTBIT
(* Left came up. Henceforth treat left transparently)
(SETQ STATE
\DLMOUSE.MIDDLE&LEFT))
NIL))
(\DLMOUSE.MIDDLE&RIGHT (* Only ignore LEFT)
(SETQ REALUTILIN (LOGAND (LOGXOR ALLUP
\MOUSE.MIDDLEBIT)
(LOGOR REALUTILIN
\MOUSE.LEFTBIT))))
(\DLMOUSE.MIDDLE&LEFT (* Only ignore RIGHT)
(SETQ REALUTILIN (LOGAND (LOGXOR ALLUP
\MOUSE.MIDDLEBIT)
(LOGOR REALUTILIN
\MOUSE.RIGHTBIT))))
(PROGN (* Remaining state is \DLMOUSE.NORMAL which means
treat mouse normally, and the only interesting
transition is back to \DLMOUSE.UP)))))
(\PUTBASE \EM.UTILIN 0 REALUTILIN)
(RETURN STATE))))
(\DOTRANSITIONS
(LAMBDA (KEYBASE OLD NEW) (* lmm "22-Apr-85 16:04")
(* OLD and NEW are keyboard state words that are known to have changed. KEYBASE is the number in hardware order of
the key corresponding to the first bit in these words. This function figures out the indices of transitioning keys
and calls the decoder.)
(for I (BITMASK ← (LLSH 1 15)) from 0 to 15
do (OR (EQ 0 (LOGAND BITMASK (LOGXOR OLD NEW)))
(\DECODETRANSITION (IPLUS I KEYBASE)
(EQ 0 (LOGAND NEW BITMASK))))
(SETQ BITMASK (LRSH BITMASK 1)))
T))
(\DECODETRANSITION
(LAMBDA (KEYNUMBER DOWNFLG) (* lmm "23-Apr-85 10:08")
(* KEYNUMBER is the key number in the hardware keyboard layout, DOWNFLG is T if the key just went down.
PENDINGINTERRUPT, bound in \KEYHANDLER, is set to the decoded character if it is an interrupt.)
(.NOTELASTUSERACTION)
(PROG (ASCIICODE (TI (\TRANSINDEX KEYNUMBER DOWNFLG)))
(SELECTC (TRANSITIONFLAGS \CURRENTKEYACTION TI)
(IGNORE.TF (RETURN))
(LOCKSHIFT.TF (SETQ ASCIICODE (COND
((fetch (KEYBOARDEVENT SHIFTORLOCK) of \LASTKEYSTATE)
(TRANSITIONSHIFTCODE \CURRENTKEYACTION TI))
(T (TRANSITIONCODE \CURRENTKEYACTION TI)))))
(NOLOCKSHIFT.TF (SETQ ASCIICODE (COND
((fetch (KEYBOARDEVENT SHIFT) of \LASTKEYSTATE)
(TRANSITIONSHIFTCODE \CURRENTKEYACTION TI))
(T (TRANSITIONCODE \CURRENTKEYACTION TI)))))
(EVENT.TF (RETURN))
(1SHIFTUP.TF (replace (KEYBOARDEVENT 1SHIFT) of \LASTKEYSTATE
with NIL)
(RETURN))
(1SHIFTDOWN.TF (replace (KEYBOARDEVENT 1SHIFT) of \LASTKEYSTATE
with T)
(RETURN))
(2SHIFTUP.TF (replace (KEYBOARDEVENT 2SHIFT) of \LASTKEYSTATE
with NIL)
(RETURN))
(2SHIFTDOWN.TF (replace (KEYBOARDEVENT 2SHIFT) of \LASTKEYSTATE
with T)
(RETURN))
(LOCKUP.TF (replace (KEYBOARDEVENT LOCK) of \LASTKEYSTATE with NIL)
(RETURN))
(LOCKDOWN.TF (replace (KEYBOARDEVENT LOCK) of \LASTKEYSTATE with T)
(RETURN))
(LOCKTOGGLE.TF (replace (KEYBOARDEVENT LOCK) of \LASTKEYSTATE
with (NOT (fetch (KEYBOARDEVENT LOCK) of
\LASTKEYSTATE)))
(RETURN))
(CTRLUP.TF (replace (KEYBOARDEVENT CTRL) of \LASTKEYSTATE with NIL)
(RETURN))
(CTRLDOWN.TF (replace (KEYBOARDEVENT CTRL) of \LASTKEYSTATE with T)
(RETURN))
(METAUP.TF (replace (KEYBOARDEVENT META) of \LASTKEYSTATE with NIL)
(RETURN))
(METADOWN.TF (replace (KEYBOARDEVENT META) of \LASTKEYSTATE with T)
(RETURN))
(FONTUP.TF (replace (KEYBOARDEVENT FONT) of \LASTKEYSTATE with NIL)
(RETURN))
(FONTDOWN.TF (replace (KEYBOARDEVENT FONT) of \LASTKEYSTATE with T)
(RETURN))
(FONTTOGGLE.TF (replace (KEYBOARDEVENT FONT) of \LASTKEYSTATE
with (NOT (fetch (KEYBOARDEVENT FONT) of
\LASTKEYSTATE)))
(RETURN))
(USERMODE1UP.TF (replace (KEYBOARDEVENT USERMODE1) of \LASTKEYSTATE
with NIL)
(RETURN))
(USERMODE1DOWN.TF (replace (KEYBOARDEVENT USERMODE1) of \LASTKEYSTATE
with T)
(RETURN))
(USERMODE1TOGGLE.TF (replace (KEYBOARDEVENT USERMODE1) of \LASTKEYSTATE
with (NOT (fetch (KEYBOARDEVENT USERMODE1)
of \LASTKEYSTATE)))
(RETURN))
(USERMODE2UP.TF (replace (KEYBOARDEVENT USERMODE2) of \LASTKEYSTATE
with NIL)
(RETURN))
(USERMODE2DOWN.TF (replace (KEYBOARDEVENT USERMODE2) of \LASTKEYSTATE
with T)
(RETURN))
(USERMODE2TOGGLE.TF (replace (KEYBOARDEVENT USERMODE2) of \LASTKEYSTATE
with (NOT (fetch (KEYBOARDEVENT USERMODE2)
of \LASTKEYSTATE)))
(RETURN))
(USERMODE3UP.TF (replace (KEYBOARDEVENT USERMODE3) of \LASTKEYSTATE
with NIL)
(RETURN))
(USERMODE3DOWN.TF (replace (KEYBOARDEVENT USERMODE3) of \LASTKEYSTATE
with T)
(RETURN))
(USERMODE3TOGGLE.TF (replace (KEYBOARDEVENT USERMODE3) of \LASTKEYSTATE
with (NOT (fetch (KEYBOARDEVENT USERMODE3)
of \LASTKEYSTATE)))
(RETURN))
(SHOULDNT))
(AND (fetch (KEYBOARDEVENT CTRL) of \LASTKEYSTATE)
(SETQ ASCIICODE (LOGAND ASCIICODE \CTRLMASK)))
(COND
((AND (OR (fetch (KEYBOARDEVENT META) of \LASTKEYSTATE)
(fetch (KEYBOARDEVENT FONT) of \LASTKEYSTATE))
(ILESSP ASCIICODE \KEYBOARD.META))
(SETQ ASCIICODE (LOGOR ASCIICODE \KEYBOARD.META))))
(COND
((ASSOC ASCIICODE (fetch INTERRUPTLIST of \CURRENTKEYACTION))
(SETQ PENDINGINTERRUPT T)
(replace WAITINGINTERRUPT of \INTERRUPTSTATE with T)
(replace INTCHARCODE of \INTERRUPTSTATE with ASCIICODE))
(T (\PUTSYSBUF ASCIICODE))))))
(MOUSECHORDWAIT
(LAMBDA MSECS (* MPL "21-Jun-85 16:31")
(DECLARE (GLOBALVARS \RCLKMILLISECOND))
(PROG1 (AND \MOUSECHORDTICKS \MOUSECHORDMILLISECONDS)
(COND
((IGREATERP MSECS 0)
(SETQ \MOUSECHORDTICKS (AND (ARG MSECS 1)
(IMIN MAX.SMALLP
(ITIMES (SETQ \MOUSECHORDMILLISECONDS
(OR (SMALLP (ARG MSECS 1))
50))
\RCLKMILLISECOND)))))))))
(\TRACKCURSOR
(LAMBDA (CURSORX CURSORY) (* gbn: "26-Jan-86 17:01")
(DECLARE (GLOBALVARS \CURSORDESTHEIGHT \CURSORDESTWIDTH))
(.NOTELASTUSERACTION)
(COND
((OR (COND
((IGEQ CURSORX (IDIFFERENCE \CURSORDESTWIDTH \CURSORHOTSPOTX))
(* Large cursor values are either out of bounds to the
right or are negative values
(16-bit bcpl signed numbers))
(COND
((IGREATERP CURSORX 32767) (* Cursor value is negative)
(COND
((ILESSP (IPLUS (SUB1 (IDIFFERENCE CURSORX 65535))
\CURSORHOTSPOTX)
0)
(* Cursor pos + hotspot is still off to the left (the IPLUS is an optimization of (\XMOUSECOORD)), so clip to
effective zero)
(SETQ CURSORX (COND
((EQ \MACHINETYPE \DANDELION)
(* Temporary workaround)
0)
(T (UNSIGNED (IMINUS \CURSORHOTSPOTX)
BITSPERWORD)))))))
(T (SETQ CURSORX (SUB1 (IDIFFERENCE \CURSORDESTWIDTH \CURSORHOTSPOTX)))))))
(IGEQ CURSORY (IDIFFERENCE \CURSORDESTHEIGHT HARDCURSORHEIGHT)))
(* repeat test so that both X and Y will get clipped
each cycle. This keeps the cursor from moving off the
screen.)
(COND
((IGEQ CURSORY (IDIFFERENCE \CURSORDESTHEIGHT \CURSORHOTSPOTY))
(* Large cursor values are either out of bounds to the
bottom or are negative values
(16-bit bcpl signed numbers))
(COND
((IGREATERP CURSORY 32767) (* Cursor value is negative)
(COND
((ILESSP (IPLUS (SUB1 (IDIFFERENCE CURSORY 65535))
\CURSORHOTSPOTY)
0) (* Cursor pos + hotspot is still off to the top, so
clip to effective zero)
(SETQ CURSORY (COND
((OR (EQ \MACHINETYPE \DANDELION)
(EQ \MACHINETYPE \DAYBREAK))
(* Temporary workaround)
0)
(T (UNSIGNED (IMINUS \CURSORHOTSPOTY)
BITSPERWORD)))))))
(T (SETQ CURSORY (SUB1 (IDIFFERENCE \CURSORDESTHEIGHT \CURSORHOTSPOTY)))))))
(* If need to clip mouse, do so here.
\SETMOUSEXY MACRO takes dlion complexities into
account.)
(\SETMOUSEXY CURSORX CURSORY)))
(COND
(\SOFTCURSORUPP (\SOFTCURSORPOSITION CURSORX CURSORY)))
(COND
((EQ \MACHINETYPE \DAYBREAK) (* Have to kick DAYBREAK IOP to track the cursor.
*)
(\DoveDisplay.SetCursorPosition CURSORX CURSORY)))
(\PUTBASE \EM.CURSORX 0 CURSORX)
(\PUTBASE \EM.CURSORY 0 CURSORY)))
)
(RPAQ? \MOUSECHORDTICKS )
(RPAQ? \MOUSECHORDMILLISECONDS 50)
(DECLARE: DONTEVAL@LOAD DOCOPY
(\KEYBOARDINIT)
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS .NOTELASTUSERACTION MACRO (NIL (\BLT \LASTUSERACTION (LOCF (fetch SECONDSTMP of \MISCSTATS)
)
WORDSPERCELL)))
)
(DECLARE: EVAL@COMPILE
(RPAQQ ALLUP 65535)
(RPAQQ \CTRLMASK 159)
(RPAQQ \METABIT 128)
(CONSTANTS ALLUP \CTRLMASK \METABIT)
)
(RPAQQ DLMOUSEBITS ((\MOUSE.LEFTBIT 4)
(\MOUSE.RIGHTBIT 2)
(\MOUSE.MIDDLEBIT 1)
(\MOUSE.ALLBITS 7)
(\MOUSE.LRBIT 6)))
(DECLARE: EVAL@COMPILE
(RPAQQ \MOUSE.LEFTBIT 4)
(RPAQQ \MOUSE.RIGHTBIT 2)
(RPAQQ \MOUSE.MIDDLEBIT 1)
(RPAQQ \MOUSE.ALLBITS 7)
(RPAQQ \MOUSE.LRBIT 6)
(CONSTANTS (\MOUSE.LEFTBIT 4)
(\MOUSE.RIGHTBIT 2)
(\MOUSE.MIDDLEBIT 1)
(\MOUSE.ALLBITS 7)
(\MOUSE.LRBIT 6))
)
(RPAQQ DLMOUSESTATES ((\DLMOUSE.UP 0)
(\DLMOUSE.WAITING 1)
(\DLMOUSE.NORMAL 2)
(\DLMOUSE.MIDDLE 3)
(\DLMOUSE.MIDDLE&LEFT 4)
(\DLMOUSE.MIDDLE&RIGHT 5)))
(DECLARE: EVAL@COMPILE
(RPAQQ \DLMOUSE.UP 0)
(RPAQQ \DLMOUSE.WAITING 1)
(RPAQQ \DLMOUSE.NORMAL 2)
(RPAQQ \DLMOUSE.MIDDLE 3)
(RPAQQ \DLMOUSE.MIDDLE&LEFT 4)
(RPAQQ \DLMOUSE.MIDDLE&RIGHT 5)
(CONSTANTS (\DLMOUSE.UP 0)
(\DLMOUSE.WAITING 1)
(\DLMOUSE.NORMAL 2)
(\DLMOUSE.MIDDLE 3)
(\DLMOUSE.MIDDLE&LEFT 4)
(\DLMOUSE.MIDDLE&RIGHT 5))
)
(RPAQQ TRANSITIONFLAGS
(CTRLDOWN.TF CTRLUP.TF IGNORE.TF EVENT.TF LOCKDOWN.TF LOCKSHIFT.TF LOCKTOGGLE.TF LOCKUP.TF
NOLOCKSHIFT.TF 1SHIFTDOWN.TF 1SHIFTUP.TF 2SHIFTDOWN.TF 2SHIFTUP.TF METADOWN.TF
METAUP.TF FONTDOWN.TF FONTUP.TF FONTTOGGLE.TF USERMODE1UP.TF USERMODE1DOWN.TF
USERMODE1TOGGLE.TF USERMODE2UP.TF USERMODE2DOWN.TF USERMODE2TOGGLE.TF USERMODE3UP.TF
USERMODE3DOWN.TF USERMODE3TOGGLE.TF))
(DECLARE: EVAL@COMPILE
(RPAQQ CTRLDOWN.TF 5)
(RPAQQ CTRLUP.TF 4)
(RPAQQ IGNORE.TF 0)
(RPAQQ EVENT.TF 1)
(RPAQQ LOCKDOWN.TF 8)
(RPAQQ LOCKSHIFT.TF 2)
(RPAQQ LOCKTOGGLE.TF 14)
(RPAQQ LOCKUP.TF 7)
(RPAQQ NOLOCKSHIFT.TF 3)
(RPAQQ 1SHIFTDOWN.TF 6)
(RPAQQ 1SHIFTUP.TF 9)
(RPAQQ 2SHIFTDOWN.TF 11)
(RPAQQ 2SHIFTUP.TF 10)
(RPAQQ METADOWN.TF 13)
(RPAQQ METAUP.TF 12)
(RPAQQ FONTDOWN.TF 24)
(RPAQQ FONTUP.TF 25)
(RPAQQ FONTTOGGLE.TF 26)
(RPAQQ USERMODE1UP.TF 15)
(RPAQQ USERMODE1DOWN.TF 16)
(RPAQQ USERMODE1TOGGLE.TF 17)
(RPAQQ USERMODE2UP.TF 18)
(RPAQQ USERMODE2DOWN.TF 19)
(RPAQQ USERMODE2TOGGLE.TF 20)
(RPAQQ USERMODE3UP.TF 21)
(RPAQQ USERMODE3DOWN.TF 22)
(RPAQQ USERMODE3TOGGLE.TF 23)
(CONSTANTS CTRLDOWN.TF CTRLUP.TF IGNORE.TF EVENT.TF LOCKDOWN.TF LOCKSHIFT.TF LOCKTOGGLE.TF LOCKUP.TF
NOLOCKSHIFT.TF 1SHIFTDOWN.TF 1SHIFTUP.TF 2SHIFTDOWN.TF 2SHIFTUP.TF METADOWN.TF METAUP.TF
FONTDOWN.TF FONTUP.TF FONTTOGGLE.TF USERMODE1UP.TF USERMODE1DOWN.TF USERMODE1TOGGLE.TF
USERMODE2UP.TF USERMODE2DOWN.TF USERMODE2TOGGLE.TF USERMODE3UP.TF USERMODE3DOWN.TF
USERMODE3TOGGLE.TF)
)
(DECLARE: EVAL@COMPILE
[PUTPROPS \TRANSINDEX MACRO ((KEYNUMBER DOWNFLG)
(COND (DOWNFLG (IPLUS \NKEYS KEYNUMBER))
(T KEYNUMBER]
(PUTPROPS ARMEDCODE MACRO ((TABLE CHAR)
(\GETBASEBIT (fetch (KEYACTION ARMED)
TABLE)
CHAR)))
(PUTPROPS TRANSITIONSHIFTCODE MACRO ((TABLE CHAR)
(\GETBASE (fetch (KEYACTION SHIFTCODES)
TABLE)
CHAR)))
(PUTPROPS TRANSITIONCODE MACRO ((TABLE CHAR)
(\GETBASE (fetch (KEYACTION CODES)
TABLE)
CHAR)))
(PUTPROPS TRANSITIONFLAGS MACRO ((TABLE CHAR)
(\GETBASEBYTE (fetch (KEYACTION FLAGS)
TABLE)
CHAR)))
)
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD KEYACTION (FLAGS CODES SHIFTCODES ARMED INTERRUPTLIST)
FLAGS ← (\ALLOCBLOCK (FOLDHI (IPLUS \NKEYS \NKEYS)
BYTESPERCELL))
CODES ← (\ALLOCBLOCK (FOLDHI (PLUS \NKEYS \NKEYS)
WORDSPERCELL))
SHIFTCODES ← (\ALLOCBLOCK (FOLDHI (PLUS \NKEYS \NKEYS)
WORDSPERCELL))
ARMED ← (\ALLOCBLOCK (FOLDHI (ADD1 \MAXTHINCHAR)
BITSPERCELL))
(CREATE (\ALLOCBLOCK 5 PTRBLOCK.GCT))
[TYPE? (AND (\BLOCKDATAP DATUM)
(EQ (\#BLOCKDATACELLS DATUM)
5)
(OR (NULL (FETCH (KEYACTION INTERRUPTLIST) OF DATUM))
(LISTP (FETCH INTERRUPTLIST OF DATUM)))
(\BLOCKDATAP (FETCH (KEYACTION FLAGS)
DATUM))
(\BLOCKDATAP (FETCH (KEYACTION CODES)
DATUM))
(\BLOCKDATAP (FETCH (KEYACTION ARMED)
DATUM])
]
(DECLARE: EVAL@COMPILE
(RPAQQ \NKEYS 112)
(CONSTANTS \NKEYS)
)
(* END EXPORTED DEFINITIONS)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD RING ((READ WORD)
(WRITE WORD)))
]
(* can get rid of shiftstate after clients have been fixed)
[DECLARE: EVAL@COMPILE
(ACCESSFNS SHIFTSTATE [[DUMMYSHIFT (NOT (EQ 0 (LOGAND (\GETBASEBYTE DATUM 0)
(LOGOR 1 2]
[DUMMY1SHIFT [NOT (EQ 0 (LOGAND 1 (\GETBASEBYTE DATUM 0]
(\PUTBASEBYTE DATUM 0 (COND
(NEWVALUE (LOGOR 1 (\GETBASEBYTE DATUM 0)))
(T (LOGAND (\GETBASEBYTE DATUM 0)
(LOGXOR \CHARMASK 1]
[DUMMY2SHIFT [NOT (EQ 0 (LOGAND 2 (\GETBASEBYTE DATUM 0]
(\PUTBASEBYTE DATUM 0 (COND
(NEWVALUE (LOGOR 2 (\GETBASEBYTE DATUM 0)))
(T (LOGAND (\GETBASEBYTE DATUM 0)
(LOGXOR \CHARMASK 2]
[DUMMYLOCK [NOT (EQ 0 (LOGAND 4 (\GETBASEBYTE DATUM 0]
(\PUTBASEBYTE DATUM 0 (COND
(NEWVALUE (LOGOR 4 (\GETBASEBYTE DATUM 0)))
(T (LOGAND (\GETBASEBYTE DATUM 0)
(LOGXOR \CHARMASK 4]
[DUMMYSHIFTORLOCK (NOT (EQ 0 (\GETBASEBYTE DATUM 0)))
(\PUTBASEBYTE DATUM 0 (COND
(NEWVALUE (HELP " Can't turn on SHIFTORLOCK"))
(T 0]
[DUMMYCTRL (NOT (EQ 0 (\GETBASEBYTE DATUM 1)))
(\PUTBASEBYTE DATUM 1 (COND
(NEWVALUE 1)
(T 0]
[DUMMYMETA (NOT (EQ 0 (\GETBASEBYTE DATUM 2)))
(\PUTBASEBYTE DATUM 2 (COND
(NEWVALUE 1)
(T 0]
[DUMMYFONT (NEQ 0 (LOGAND (LLSH 1 3)
(\GETBASEBYTE DATUM 3)))
(\PUTBASEBYTE DATUM 3 (COND
(NEWVALUE (LOGOR (LLSH 1 3)
(\GETBASEBYTE DATUM 3)))
(T (LOGAND (\GETBASEBYTE DATUM 3)
(LOGXOR \CHARMASK (LLSH 1 3]
[DUMMYUSERMODE1 (NEQ 0 (LOGAND (LLSH 1 0)
(\GETBASEBYTE DATUM 3)))
(\PUTBASEBYTE DATUM 3 (COND
(NEWVALUE (LOGOR (LLSH 1 0)
(\GETBASEBYTE DATUM 3)))
(T (LOGAND (\GETBASEBYTE DATUM 3)
(LOGXOR \CHARMASK (LLSH 1 0]
[DUMMYUSERMODE2 (NEQ 0 (LOGAND (LLSH 1 1)
(\GETBASEBYTE DATUM 3)))
(\PUTBASEBYTE DATUM 3 (COND
(NEWVALUE (LOGOR (LLSH 1 1)
(\GETBASEBYTE DATUM 3)))
(T (LOGAND (\GETBASEBYTE DATUM 3)
(LOGXOR \CHARMASK (LLSH 1 1]
(DUMMYUSERMODE3 (NEQ 0 (LOGAND (LLSH 1 2)
(\GETBASEBYTE DATUM 3)))
(\PUTBASEBYTE DATUM 3 (COND
(NEWVALUE (LOGOR (LLSH 1 2)
(\GETBASEBYTE DATUM 3)))
(T (LOGAND (\GETBASEBYTE DATUM 3)
(LOGXOR \CHARMASK (LLSH 1 2]
(CREATE (\ALLOCBLOCK (FOLDHI 3 BYTESPERCELL))))
]
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \SHIFTSTATE \MOUSETIMERTEMP)
)
(DECLARE: EVAL@COMPILE
(RPAQQ NRINGINDEXWORDS 2)
(CONSTANTS NRINGINDEXWORDS)
)
(DECLARE: EVAL@COMPILE
(RPAQ \SYSBUFFER.FIRST (UNFOLD NRINGINDEXWORDS BYTESPERWORD))
(RPAQ \SYSBUFFER.LAST (IPLUS \SYSBUFFER.FIRST (SUB1 \SYSBUFSIZE)))
[CONSTANTS (\SYSBUFFER.FIRST (UNFOLD NRINGINDEXWORDS BYTESPERWORD))
(\SYSBUFFER.LAST (IPLUS \SYSBUFFER.FIRST (SUB1 \SYSBUFSIZE]
)
)
(DECLARE: EVAL@COMPILE
(RPAQQ \KEYNAMES ((5 %% FIVE)
(4 $ FOUR)
(6 ~ SIX)
(e E)
(7 & SEVEN)
(d D)
(u U)
(v V)
(0 %) ZERO)
(k K)
(- %)
(p P)
(/ ?)
(\ %| FONT LOOKS)
(LF SAME)
(BS <-)
(3 # THREE)
(2 @ TWO)
(w W)
(q Q)
(s S)
(a A)
(9 %( NINE)
(i I)
(x X)
(o O)
(l L)
(%, <)
(' %")
(%] })
(BLANK-MIDDLE OPEN DBK-HELP)
(BLANK-TOP KEYBOARD DBK-META)
(1 ! ONE)
(ESC ESCAPE ->)
(TAB =>)
(f F)
(CTRL PROP'S EDIT)
(c C)
(j J)
(b B)
(z Z)
(LSHIFT)
(%. >)
(; :)
(CR <-%|)
(← ↑)
(DEL DELETE)
(SKIP NEXT)
(r R)
(t T)
(g G)
(y Y)
(h H)
(8 * EIGHT)
(n N)
(m M)
(LOCK)
(SPACE)
(%[ {)
(= +)
(RSHIFT)
(BLANK-BOTTOM STOP)
(MOVE)
(UNDO)
(UTIL0)
(UTIL1)
(UTIL2 SUPER/SUB)
(UTIL3 CASE)
(UTIL4 STRIKEOUT)
(UTIL5 KEYPAD2)
(UTIL6 KEYPAD3 PGDN)
(UTIL7)
(PAD1 LEFTKEY CAPSLOCK KEYPAD+)
(PAD2 LEFTMIDDLEKEY NUMLOCK KEYPAD-)
(PAD3 MIDDLEKEY SCROLLLOCK KEYPAD*)
(PAD4 RIGHTMIDDLEKEY BREAK KEYPAD/)
(PAD5 RIGHTKEY DOIT PRTSC)
(LEFT RED MOUSERED)
(RIGHT BLUE MOUSEBLUE)
(MIDDLE YELLOW MOUSEYELLOW)
(MARGINS)
(K41 KEYPAD7 HOME)
(K42 KEYPAD8)
(K43 KEYPAD9 PGUP)
(K44 KEYPAD4)
(K45 KEYPAD5)
(K46)
(K47 KEYPAD6)
(K48)
(COPY)
(FIND)
(AGAIN)
(HELP)
(DEF'N EXPAND)
(K4E KEYPAD1 END)
(ALWAYS-ON-1)
(ALWAYS-ON-2)
(CENTER)
(K52 KEYPAD0 INS)
(BOLD)
(ITALICS)
(UNDERLINE)
(SUPERSCRIPT)
(SUBSCRIPT)
(LARGER SMALLER)
(K59 KEYPAD%| KEYPAD.)
(K5A KEYPAD\ KEYPAD,)
(K5B)
(K5C)
(DEFAULTS)
(K5E)
(K5F)))
)
(RPAQQ \ORIGKEYACTIONS ((0 (53 %% NOLOCKSHIFT))
(1 (52 $ NOLOCKSHIFT))
(2 (54 ~ NOLOCKSHIFT))
(3 (e E LOCKSHIFT))
(4 (55 & NOLOCKSHIFT))
(5 (d D LOCKSHIFT))
(6 (u U LOCKSHIFT))
(7 (v V LOCKSHIFT))
(8 (48 %) NOLOCKSHIFT))
(9 (k K LOCKSHIFT))
(10 (- - NOLOCKSHIFT))
(11 (p P LOCKSHIFT))
(12 (/ ? NOLOCKSHIFT))
(13 (\ %| NOLOCKSHIFT))
(14 (10 96 NOLOCKSHIFT))
(15 (8 8 NOLOCKSHIFT))
(16 (51 # NOLOCKSHIFT))
(17 (50 @ NOLOCKSHIFT))
(18 (w W LOCKSHIFT))
(19 (q Q LOCKSHIFT))
(20 (s S LOCKSHIFT))
(21 (a A LOCKSHIFT))
(22 (57 %( NOLOCKSHIFT))
(23 (i I LOCKSHIFT))
(24 (x X LOCKSHIFT))
(25 (o O LOCKSHIFT))
(26 (l L LOCKSHIFT))
(27 (%, < NOLOCKSHIFT))
(28 (' %" NOLOCKSHIFT))
(29 (%] } NOLOCKSHIFT))
(30 (194 194 NOLOCKSHIFT))
(31 (193 193 NOLOCKSHIFT))
(32 (49 ! NOLOCKSHIFT))
(33 (27 27 NOLOCKSHIFT))
(34 (9 9 NOLOCKSHIFT))
(35 (f F LOCKSHIFT))
(36 CTRLDOWN . CTRLUP)
(37 (c C LOCKSHIFT))
(38 (j J LOCKSHIFT))
(39 (b B LOCKSHIFT))
(40 (z Z LOCKSHIFT))
(41 1SHIFTDOWN . 1SHIFTUP)
(42 (%. > NOLOCKSHIFT))
(43 (; : NOLOCKSHIFT))
(44 (13 13 NOLOCKSHIFT))
(45 (← ↑ NOLOCKSHIFT))
(46 (127 535 NOLOCKSHIFT))
(47 (%( %[ NOLOCKSHIFT))
(48 (r R LOCKSHIFT))
(49 (t T LOCKSHIFT))
(50 (g G LOCKSHIFT))
(51 (y Y LOCKSHIFT))
(52 (h H LOCKSHIFT))
(53 (56 * NOLOCKSHIFT))
(54 (n N LOCKSHIFT))
(55 (m M LOCKSHIFT))
(56 LOCKDOWN . LOCKUP)
(57 (32 32 NOLOCKSHIFT))
(58 (%[ { NOLOCKSHIFT))
(59 (= + NOLOCKSHIFT))
(60 2SHIFTDOWN . 2SHIFTUP)
(61 (195 195 NOLOCKSHIFT))
(63 (%) %] NOLOCKSHIFT))
(77 EVENT . EVENT)
(78 EVENT . EVENT)
(79 EVENT . EVENT)
(102 LOCKDOWN)
(103 LOCKUP)))
(RPAQQ \DLIONKEYACTIONS ((2 (54 ↑ NOLOCKSHIFT))
(10 (- ← NOLOCKSHIFT))
(33 (\ %| NOLOCKSHIFT))
(45 (96 ~ NOLOCKSHIFT))
(OPEN METADOWN . METAUP)
(PROP'S CTRLDOWN . CTRLUP)
(SAME METADOWN . METAUP)
(FIND (2,3 2,43 NOLOCKSHIFT))
(UNDO (2,4 2,44 NOLOCKSHIFT))
(STOP (5 7 NOLOCKSHIFT))
(MOVE)
(COPY)
(AGAIN (2,10 2,50 NOLOCKSHIFT))
(CENTER (2,101 2,141 NOLOCKSHIFT))
(BOLD (2,102 2,142 NOLOCKSHIFT))
(ITALICS (2,103 2,143 NOLOCKSHIFT))
(UNDERLINE (2,106 2,146 NOLOCKSHIFT))
(SUPERSCRIPT (2,113 2,153 NOLOCKSHIFT))
(SUBSCRIPT (2,114 2,154 NOLOCKSHIFT))
(LARGER (2,110 2,150 NOLOCKSHIFT))
(DEFAULTS (2,115 2,155 NOLOCKSHIFT))
(93 (27 2,64 NOLOCKSHIFT))
(47 (2,22 2,62 NOLOCKSHIFT))
(31 (2,5 2,45 NOLOCKSHIFT))
(92 (2,1 2,41 NOLOCKSHIFT))
(80 (2,13 2,53 NOLOCKSHIFT))
(FONT (2,112 2,152 NOLOCKSHIFT))))
(RPAQQ \DLIONOSDKEYACTIONS ((56 LOCKTOGGLE)))
(RPAQQ \DORADOKEYACTIONS ((2 (54 ~ NOLOCKSHIFT))
(10 (- - NOLOCKSHIFT))
(13 (\ %| NOLOCKSHIFT))
(14 (10 96 NOLOCKSHIFT))
(33 (27 27 NOLOCKSHIFT))
(45 (← ↑ NOLOCKSHIFT))))
(RPAQQ \DOVEKEYACTIONS ((2 (54 ↑ NOLOCKSHIFT))
(10 (- ← NOLOCKSHIFT))
(33 (27 27 NOLOCKSHIFT))
(56 CTRLDOWN . CTRLUP)
(65 (27 27 NOLOCKSHIFT))
(71 (39 34 NOLOCKSHIFT))
(93 (2,24 2,64 NOLOCKSHIFT))
(108 (96 126 NOLOCKSHIFT))
(DBK-META METADOWN . METAUP)
(DBK-HELP (2,1 2,41 NOLOCKSHIFT))
(SAME METADOWN . METAUP)
(FIND (2,3 2,43 NOLOCKSHIFT))
(UNDO (2,4 2,44 NOLOCKSHIFT))
(STOP (5 7 NOLOCKSHIFT))
(EDIT (2,5 2,45 NOLOCKSHIFT))
(MOVE)
(COPY)
(AGAIN (2,10 2,50 NOLOCKSHIFT))
(CENTER (2,101 2,141 NOLOCKSHIFT))
(BOLD (2,102 2,142 NOLOCKSHIFT))
(ITALICS (2,103 2,143 NOLOCKSHIFT))
(CASE (2,104 2,144 NOLOCKSHIFT))
(STRIKEOUT (2,105 2,145 NOLOCKSHIFT))
(UNDERLINE (2,106 2,146 NOLOCKSHIFT))
(SUPER/SUB (2,107 2,147 NOLOCKSHIFT))
(LARGER (2,110 2,150 NOLOCKSHIFT))
(MARGINS (2,111 2,151 NOLOCKSHIFT))
(LOOKS (2,112 2,152 NOLOCKSHIFT))
(CAPSLOCK LOCKTOGGLE)
(NUMLOCK (2,11 - NOLOCKSHIFT))
(SCROLLLOCK (2,12 180 NOLOCKSHIFT))
(BREAK (2 184 NOLOCKSHIFT))
(DOIT (2,13 2,53 NOLOCKSHIFT))
(KEYPAD7 (2,14 55 NOLOCKSHIFT))
(KEYPAD8 (173 56 NOLOCKSHIFT))
(KEYPAD9 (2,15 57 NOLOCKSHIFT))
(KEYPAD4 (172 52 NOLOCKSHIFT))
(KEYPAD5 (2,16 53 NOLOCKSHIFT))
(KEYPAD6 (174 54 NOLOCKSHIFT))
(KEYPAD1 (2,17 49 NOLOCKSHIFT))
(KEYPAD2 (175 50 NOLOCKSHIFT))
(KEYPAD3 (2,20 51 NOLOCKSHIFT))
(KEYPAD0 (2,21 48 NOLOCKSHIFT))
(KEYPAD%| (%| 46 NOLOCKSHIFT))
(KEYPAD\ (\ 44 NOLOCKSHIFT))
(47 (2,22 2,62 NOLOCKSHIFT))))
(RPAQQ \DOVEOSDKEYACTIONS ((56 LOCKDOWN . LOCKUP)
(36 CTRLDOWN . CTRLUP)
(CAPSLOCK (2,5 2,45 NOLOCKSHIFT))))
(RPAQ? \KEYBOARD.META 256)
(RPAQ? \MODIFIED.KEYACTIONS )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \SYSBUFFER \LONGSYSBUF \INTERRUPTSTATE \MODIFIED.KEYACTIONS \RCLKSECOND \LASTUSERACTION
\MOUSECHORDTICKS \LASTKEYSTATE \KEYBOARDEVENTQUEUE \KEYBUFFERING \CURRENTKEYACTION
\DEFAULTKEYACTION \TIMER.INTERRUPT.PENDING \ORIGKEYACTIONS \KEYBOARD.META
\MOUSECHORDMILLISECONDS \DORADOKEYACTIONS \DLIONKEYACTIONS \DLIONOSDKEYACTIONS \DOVEKEYACTIONS
\DOVEOSDKEYACTIONS)
)
(* Key interpretation)
(DEFINEQ
(KEYACTION
(LAMBDA (KEYNAME ACTIONS TABLE) (* lmm "22-May-85 07:41")
(LET ((NUMB (OR (SMALLP KEYNAME)
(\KEYNAMETONUMBER KEYNAME)))
(TABLE (OR TABLE \DEFAULTKEYACTION)))
(CONS (\KEYACTION1 (\TRANSINDEX NUMB T)
(AND ACTIONS (OR (CAR ACTIONS)
(QUOTE IGNORE)))
TABLE)
(\KEYACTION1 (\TRANSINDEX NUMB NIL)
(AND ACTIONS (OR (CDR ACTIONS)
(QUOTE IGNORE)))
TABLE)))))
(KEYACTIONTABLE
(LAMBDA (OLD) (* gbn: "26-Jan-86 17:02")
(if OLD
then (create KEYACTION copying OLD)
else (PROG1 (SETQ OLD (create KEYACTION))
(for X in \ORIGKEYACTIONS do (KEYACTION (CAR X)
(CDR X)
OLD))))))
(\KEYACTION1
(LAMBDA (TI ACTION TABLE) (* lmm "18-Apr-85 06:14")
(PROG1 (SELECTC (TRANSITIONFLAGS TABLE TI)
(IGNORE.TF (QUOTE IGNORE))
((LIST LOCKSHIFT.TF NOLOCKSHIFT.TF)
(LIST (TRANSITIONCODE TABLE TI)
(TRANSITIONSHIFTCODE TABLE TI)
(COND
((EQ LOCKSHIFT.TF (TRANSITIONFLAGS TABLE TI))
(QUOTE LOCKSHIFT))
(T (QUOTE NOLOCKSHIFT)))))
(EVENT.TF (QUOTE EVENT))
(CTRLDOWN.TF (QUOTE CTRLDOWN))
(CTRLUP.TF (QUOTE CTRLUP))
(1SHIFTDOWN.TF (QUOTE 1SHIFTDOWN))
(1SHIFTUP.TF (QUOTE 1SHIFTUP))
(2SHIFTDOWN.TF (QUOTE 2SHIFTDOWN))
(2SHIFTUP.TF (QUOTE 2SHIFTUP))
(LOCKDOWN.TF (QUOTE LOCKDOWN))
(LOCKUP.TF (QUOTE LOCKUP))
(LOCKTOGGLE.TF (QUOTE LOCKTOGGLE))
(METADOWN.TF (QUOTE METADOWN))
(METAUP.TF (QUOTE METAUP))
(FONTUP.TF (QUOTE FONTUP))
(FONTDOWN.TF (QUOTE FONTDOWN))
(FONTTOGGLE.TF (QUOTE FONTTOGGLE))
(USERMODE1UP.TF (QUOTE USERMODE1UP))
(USERMODE1DOWN.TF (QUOTE USERMODE1DOWN))
(USERMODE1TOGGLE.TF (QUOTE USERMODE1TOGGLE))
(USERMODE2UP.TF (QUOTE USERMODE2UP))
(USERMODE2DOWN.TF (QUOTE USERMODE2DOWN))
(USERMODE2TOGGLE.TF (QUOTE USERMODE2TOGGLE))
(USERMODE3UP.TF (QUOTE USERMODE3UP))
(USERMODE3DOWN.TF (QUOTE USERMODE3DOWN))
(USERMODE3TOGGLE.TF (QUOTE USERMODE3TOGGLE))
(SHOULDNT))
(SELECTQ ACTION
((NIL NOCHANGE))
(IGNORE (change (TRANSITIONFLAGS TABLE TI)
IGNORE.TF))
(EVENT (change (TRANSITIONFLAGS TABLE TI)
EVENT.TF))
(CTRLUP (change (TRANSITIONFLAGS TABLE TI)
CTRLUP.TF))
(CTRLDOWN (change (TRANSITIONFLAGS TABLE TI)
CTRLDOWN.TF))
(1SHIFTUP (change (TRANSITIONFLAGS TABLE TI)
1SHIFTUP.TF))
(1SHIFTDOWN (change (TRANSITIONFLAGS TABLE TI)
1SHIFTDOWN.TF))
(2SHIFTUP (change (TRANSITIONFLAGS TABLE TI)
2SHIFTUP.TF))
(2SHIFTDOWN (change (TRANSITIONFLAGS TABLE TI)
2SHIFTDOWN.TF))
(LOCKUP (change (TRANSITIONFLAGS TABLE TI)
LOCKUP.TF))
(LOCKDOWN (change (TRANSITIONFLAGS TABLE TI)
LOCKDOWN.TF))
(LOCKTOGGLE (change (TRANSITIONFLAGS TABLE TI)
LOCKTOGGLE.TF))
(METAUP (change (TRANSITIONFLAGS TABLE TI)
METAUP.TF))
(METADOWN (change (TRANSITIONFLAGS TABLE TI)
METADOWN.TF))
(FONTUP (change (TRANSITIONFLAGS TABLE TI)
FONTUP.TF))
(FONTDOWN (change (TRANSITIONFLAGS TABLE TI)
FONTDOWN.TF))
(FONTTOGGLE (change (TRANSITIONFLAGS TABLE TI)
FONTTOGGLE.TF))
(USERMODE1UP (change (TRANSITIONFLAGS TABLE TI)
USERMODE1UP.TF))
(USERMODE1DOWN (change (TRANSITIONFLAGS TABLE TI)
USERMODE1DOWN.TF))
(USERMODE1TOGGLE (change (TRANSITIONFLAGS TABLE TI)
USERMODE1TOGGLE.TF))
(USERMODE2UP (change (TRANSITIONFLAGS TABLE TI)
USERMODE2UP.TF))
(USERMODE2DOWN (change (TRANSITIONFLAGS TABLE TI)
USERMODE2DOWN.TF))
(USERMODE2TOGGLE (change (TRANSITIONFLAGS TABLE TI)
USERMODE2TOGGLE.TF))
(USERMODE3UP (change (TRANSITIONFLAGS TABLE TI)
USERMODE3UP.TF))
(USERMODE3DOWN (change (TRANSITIONFLAGS TABLE TI)
USERMODE3DOWN.TF))
(USERMODE3TOGGLE (change (TRANSITIONFLAGS TABLE TI)
USERMODE3TOGGLE.TF))
(PROG (CODE SHIFTCODE ACT)
(COND
((AND (OR (\CHARCODEP (SETQ CODE (\GETCHARCODE
(CAR (LISTP ACTION)))))
(SETQ CODE (APPLY* (FUNCTION CHARCODE)
(CAR (LISTP ACTION)))))
(OR (\CHARCODEP (SETQ SHIFTCODE
(\GETCHARCODE
(CAR (SETQ ACT
(LISTP (CDR ACTION)))))))
(SETQ SHIFTCODE (APPLY* (FUNCTION CHARCODE)
(CAR ACT))))
(OR (NULL (SETQ ACT (CDR ACT)))
(LISTP ACT))
(SELECTQ (CAR ACT)
((LOCKSHIFT T)
(change (TRANSITIONFLAGS TABLE TI)
LOCKSHIFT.TF))
((NOLOCKSHIFT NIL)
(change (TRANSITIONFLAGS TABLE TI)
NOLOCKSHIFT.TF))
NIL))
(change (TRANSITIONCODE TABLE TI)
CODE)
(change (TRANSITIONSHIFTCODE TABLE TI)
SHIFTCODE))
(T (\ILLEGAL.ARG ACTION))))))))
(KEYDOWNP
(LAMBDA (KEYNAME) (* lmm "18-Apr-85 02:09")
(* T if the indicated key is instantaneously down.)
(\NEWKEYDOWNP (\KEYNAMETONUMBER KEYNAME))))
(\KEYNAMETONUMBER
(LAMBDA (KEYNAME) (* rmk: " 2-SEP-83 10:29")
(DECLARE (GLOBALVARS \KEYNAMES)) (* The fast case is when KEYNAME is lower-case)
(for X N in \KEYNAMES as I from 0 when (EQMEMB KEYNAME X) do (RETURN I)
finally (RETURN (OR (AND (NEQ KEYNAME (SETQ N (L-CASE KEYNAME)))
(for Y in \KEYNAMES as I from 0
when (EQMEMB N Y) do (RETURN I)))
(\ILLEGAL.ARG KEYNAME))))))
(MODIFY.KEYACTIONS
(LAMBDA (KeyActions SaveCurrent?) (* JonL "11-MAY-83 18:29")
(PROG1 (if SaveCurrent?
then (SETQ \MODIFIED.KEYACTIONS (for ITEM in KeyActions
collect (CONS (CAR ITEM)
(KEYACTION (CAR ITEM))))
))
(for X in KeyActions do (KEYACTION (CAR X)
(CDR X))))))
(METASHIFT
(LAMBDA FLG (* bvm: "29-APR-82 15:22")
(* Sets interpretation of swat key to first arg, where
T means meta-shift, NIL means original setting.
Returns previous setting)
(PROG ((METASTATUS (QUOTE (METADOWN . METAUP)))
OLDSETTING)
(SETQ OLDSETTING (KEYACTION (QUOTE BLANK-BOTTOM)
(AND (IGREATERP FLG 0)
(COND
((EQ (ARG FLG 1)
T)
METASTATUS)
(T (OR (ARG FLG 1)
(CDR (ASSOC (QUOTE BLANK-BOTTOM)
\ORIGKEYACTIONS))))))))
(RETURN (COND
((EQUAL OLDSETTING METASTATUS)
T)
(T OLDSETTING))))))
(SHIFTDOWNP
(LAMBDA (SHIFT) (* lmm "18-Apr-85 01:07")
(* Tells whether a given shift is down)
(SELECTQ SHIFT
(LOCK (fetch (KEYBOARDEVENT LOCK) of \LASTKEYSTATE))
(META (fetch (KEYBOARDEVENT META) of \LASTKEYSTATE))
(SHIFT (OR (fetch (KEYBOARDEVENT 1SHIFT) of \LASTKEYSTATE)
(fetch (KEYBOARDEVENT 2SHIFT) of \LASTKEYSTATE)))
(1SHIFT (fetch (KEYBOARDEVENT 1SHIFT) of \LASTKEYSTATE))
(2SHIFT (fetch (KEYBOARDEVENT 2SHIFT) of \LASTKEYSTATE))
(SHIFTORLOCK (OR (fetch (KEYBOARDEVENT 1SHIFT) of \LASTKEYSTATE)
(fetch (KEYBOARDEVENT 2SHIFT) of \LASTKEYSTATE)
(fetch (KEYBOARDEVENT LOCK) of \LASTKEYSTATE)))
(CTRL (fetch (KEYBOARDEVENT CTRL) of \LASTKEYSTATE))
(FONT (fetch (KEYBOARDEVENT FONT) of \LASTKEYSTATE))
(USERMODE1 (fetch (KEYBOARDEVENT USERMODE1) of \LASTKEYSTATE))
(USERMODE2 (fetch (KEYBOARDEVENT USERMODE2) of \LASTKEYSTATE))
(USERMODE3 (fetch (KEYBOARDEVENT USERMODE3) of \LASTKEYSTATE))
(\ILLEGAL.ARG SHIFT))))
)
(* To support office style 1108 & 1186 keyboards)
(DEFINEQ
(SETUP.OFFICE.KEYBOARD
(LAMBDA NIL (* jds " 8-Oct-85 16:27")
(SELECTQ (MACHINETYPE)
(DANDELION (MODIFY.KEYACTIONS \DLIONOSDKEYACTIONS))
(DOVE (MODIFY.KEYACTIONS \DOVEOSDKEYACTIONS))
NIL)))
)
(DECLARE: EVAL@COMPILE
[PUTPROPS \KEYNAMETONUMBER MACRO (X (LET [(CE (CONSTANTEXPRESSIONP (CAR X]
(COND (CE (\KEYNAMETONUMBER (CAR CE)))
(T (QUOTE IGNOREMACRO]
(PUTPROPS \TEMPCOPYTIMER MACRO ((X)
(PROGN (\BLT \MOUSETIMERTEMP (LOCF X)
WORDSPERCELL)
\MOUSETIMERTEMP)))
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
[PUTPROPS XKEYDOWNP MACRO ((KEYNAME)
(KEYDOWNP1 (\KEYNAMETONUMBER KEYNAME]
[PUTPROPS KEYDOWNP MACRO ((KEYNAME)
(\NEWKEYDOWNP (\KEYNAMETONUMBER KEYNAME]
[PUTPROPS KEYDOWNP1 MACRO (OPENLAMBDA (KEYNUMBER)
(DECLARE (GLOBALVARS \EM.KBDAD0 \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3
\EM.UTILIN \EM.KBDAD4 \EM.KBDAD5))
(PROG NIL (RETURN (EQ 0 (LOGAND (LRSH (LLSH 1 15)
(PROGN (* (IMOD KEYNUMBER
BITSPERWORD)
- GETD cause IMOD
and BITSPERWORD not
exported to user)
(LOGAND KEYNUMBER 15)))
(\GETBASE (SELECTQ
(PROGN (* (FOLDLO
KEYNUMBER
BITSPERWORD
)
GETD follows
since FOLDLO and
BITSPERWORD not
exported to user
)
(LRSH KEYNUMBER 4))
(0 \EM.KBDAD0)
(1 \EM.KBDAD1)
(2 \EM.KBDAD2)
(3 \EM.KBDAD3)
(4 \EM.UTILIN)
(5 (OR \EM.KBDAD4 (RETURN)
))
(6 (OR \EM.KBDAD5 (RETURN)
))
(RETURN))
0]
[PUTPROPS \NEWKEYDOWNP MACRO ((KEYNUMBER)
(EQ 0 (\GETBASEBIT \LASTKEYSTATE KEYNUMBER]
)
(* END EXPORTED DEFINITIONS)
(* A raw keyboard device/stream)
(DEFINEQ
(\INIT.KEYBOARD.STREAM
(LAMBDA NIL (* lmm "23-May-85 15:47")
(DECLARE (GLOBALVARS \KEYBOARD.DEVICE \KEYBOARD.STREAM))
(\DEFINEDEVICE (QUOTE KEYBOARD)
(SETQ \KEYBOARD.DEVICE (create FDEV
DEVICENAME ← (QUOTE KEYBOARD)
CLOSEFILE ← (FUNCTION NILL)
EVENTFN ← (FUNCTION \KEYBOARDEVENTFN)
BIN ← (FUNCTION \GETKEY)
PEEKBIN ← (FUNCTION \PEEKSYSBUF)
READP ← (FUNCTION \SYSBUFP)
EOFP ← (FUNCTION NILL)
GETFILENAME ← (FUNCTION (LAMBDA (X MODE)
(if (EQ MODE (QUOTE INPUT))
then \KEYBOARD.STREAM))))))
(SETQ \KEYBOARD.STREAM (create STREAM
USERCLOSEABLE ← NIL
USERVISIBLE ← NIL
FULLFILENAME ← (QUOTE {KEYBOARD})
DEVICE ← \KEYBOARD.DEVICE
ACCESS ← (QUOTE INPUT)))))
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(\INIT.KEYBOARD.STREAM)
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \KEYBOARD.DEVICE \KEYBOARD.STREAM)
)
(* END EXPORTED DEFINITIONS)
(* Hook for a periodic interrupt)
(DEFINEQ
(\DOBUFFEREDTRANSITIONS
(LAMBDA (\INTERRUPTABLE)
(DECLARE (SPECVARS \INTERRUPTABLE)) (* bvm: " 8-Oct-85 17:47")
(SETQ \KEYBUFFERING (QUOTE INPROGRESS))
(LET ((PENDINGINTERRUPT))
(DECLARE (SPECVARS PENDINGINTERRUPT)) (* Used by \DECODETRANSITION)
(bind R RPTR until (EQ 0 (SETQ R (fetch (RING READ) of \KEYBOARDEVENTQUEUE)))
do (SETQ RPTR (\ADDBASE \KEYBOARDEVENTQUEUE R))
(* get pointer to this event)
(* handle simple keyboard words by calling
\DOTRANSITIONS for each word)
(COND
((NEQ (fetch (KEYBOARDEVENT W0) of RPTR)
(fetch (KEYBOARDEVENT W0) of \LASTKEYSTATE))
(\DOTRANSITIONS 0 (fetch (KEYBOARDEVENT W0) of \LASTKEYSTATE)
(fetch (KEYBOARDEVENT W0) of RPTR))
(replace (KEYBOARDEVENT W0) of \LASTKEYSTATE with (fetch (KEYBOARDEVENT
W0)
of RPTR))))
(COND
((NEQ (fetch (KEYBOARDEVENT W1) of RPTR)
(fetch (KEYBOARDEVENT W1) of \LASTKEYSTATE))
(\DOTRANSITIONS 16 (fetch (KEYBOARDEVENT W1) of \LASTKEYSTATE)
(fetch (KEYBOARDEVENT W1) of RPTR))
(replace (KEYBOARDEVENT W1) of \LASTKEYSTATE with (fetch (KEYBOARDEVENT
W1)
of RPTR))))
(COND
((NEQ (fetch (KEYBOARDEVENT W2) of RPTR)
(fetch (KEYBOARDEVENT W2) of \LASTKEYSTATE))
(\DOTRANSITIONS 32 (fetch (KEYBOARDEVENT W2) of \LASTKEYSTATE)
(fetch (KEYBOARDEVENT W2) of RPTR))
(replace (KEYBOARDEVENT W2) of \LASTKEYSTATE with (fetch (KEYBOARDEVENT
W2)
of RPTR))))
(COND
((NEQ (fetch (KEYBOARDEVENT W3) of RPTR)
(fetch (KEYBOARDEVENT W3) of \LASTKEYSTATE))
(\DOTRANSITIONS 48 (fetch (KEYBOARDEVENT W3) of \LASTKEYSTATE)
(fetch (KEYBOARDEVENT W3) of RPTR))
(replace (KEYBOARDEVENT W3) of \LASTKEYSTATE with (fetch (KEYBOARDEVENT
W3)
of RPTR))))
(COND
((NEQ (fetch (KEYBOARDEVENT W4) of RPTR)
(fetch (KEYBOARDEVENT W4) of \LASTKEYSTATE))
(\DOTRANSITIONS 80 (fetch (KEYBOARDEVENT W4) of \LASTKEYSTATE)
(fetch (KEYBOARDEVENT W4) of RPTR))
(replace (KEYBOARDEVENT W4) of \LASTKEYSTATE with (fetch (KEYBOARDEVENT
W4)
of RPTR))))
(COND
((NEQ (fetch (KEYBOARDEVENT W5) of RPTR)
(fetch (KEYBOARDEVENT W5) of \LASTKEYSTATE))
(\DOTRANSITIONS 96 (fetch (KEYBOARDEVENT W5) of \LASTKEYSTATE)
(fetch (KEYBOARDEVENT W5) of RPTR))
(replace (KEYBOARDEVENT W5) of \LASTKEYSTATE with (fetch (KEYBOARDEVENT
W5)
of RPTR))))
(COND
((NEQ (fetch (KEYBOARDEVENT WU) of RPTR)
(fetch (KEYBOARDEVENT WU) of \LASTKEYSTATE))
(\DOTRANSITIONS 64 (fetch (KEYBOARDEVENT WU) of \LASTKEYSTATE)
(fetch (KEYBOARDEVENT WU) of RPTR))
(replace (KEYBOARDEVENT WU) of \LASTKEYSTATE with (fetch (KEYBOARDEVENT
WU)
of RPTR))))
(* * now remove event from queue)
(COND
((EQ (replace (RING READ) of \KEYBOARDEVENTQUEUE
with (COND
((IGEQ R \KEYBOARDEVENT.LAST)
\KEYBOARDEVENT.FIRST)
(T (IPLUS \KEYBOARDEVENT.SIZE R))))
(fetch (RING WRITE) of \KEYBOARDEVENTQUEUE))
(replace (RING READ) of \KEYBOARDEVENTQUEUE with 0))))
(PROGN (* update dummy shift state)
(replace DUMMY1SHIFT of \SHIFTSTATE with (fetch (KEYBOARDEVENT 1SHIFT)
of \LASTKEYSTATE))
(replace DUMMY2SHIFT of \SHIFTSTATE with (fetch (KEYBOARDEVENT 2SHIFT)
of \LASTKEYSTATE))
(replace DUMMYLOCK of \SHIFTSTATE with (fetch (KEYBOARDEVENT LOCK)
of \LASTKEYSTATE))
(replace DUMMYCTRL of \SHIFTSTATE with (fetch (KEYBOARDEVENT CTRL)
of \LASTKEYSTATE))
(replace DUMMYMETA of \SHIFTSTATE with (fetch (KEYBOARDEVENT META)
of \LASTKEYSTATE))
(replace DUMMYFONT of \SHIFTSTATE with (fetch (KEYBOARDEVENT FONT)
of \LASTKEYSTATE))
(replace DUMMYUSERMODE1 of \SHIFTSTATE with (fetch (KEYBOARDEVENT
USERMODE1)
of \LASTKEYSTATE))
(replace DUMMYUSERMODE2 of \SHIFTSTATE with (fetch (KEYBOARDEVENT
USERMODE2)
of \LASTKEYSTATE))
(replace DUMMYUSERMODE3 of \SHIFTSTATE with (fetch (KEYBOARDEVENT
USERMODE3)
of \LASTKEYSTATE)))
(* Note: there is a window between the test of READ above and the setting of \KEYBUFFERING below where a keyboard
transition can be ignored until the next transition causes \KEYBUFFERING to be set again)
(COND
((NOT (OR PENDINGINTERRUPT \PENDINGINTERRUPT))
(* No interrupt noticed this time or on any previous
invocation)
(SETQ \KEYBUFFERING NIL))
((NOT (\GETBASEPTR (\STKSCAN (QUOTE \INTERRUPTABLE))
0)) (* We're not interruptable, so try again later)
(SETQ \PENDINGINTERRUPT T)
(SETQ \KEYBUFFERING NIL))
(T (SETQ \PENDINGINTERRUPT NIL)
(SETQ \KEYBUFFERING NIL)
(LET ((\INTERRUPTABLE T))
(INTERRUPTED)))))))
(\TIMER.INTERRUPTFRAME
(LAMBDA NIL (* lmm "22-Apr-85 09:47")
(* place holder for periodic interrupts)
(if NIL
then (APPLY* \PERIODIC.INTERRUPT)
(if \PERIODIC.INTERRUPT
then (SETUPTIMER (QUOTIENT (TIMES \PERIODIC.INTERRUPT.FREQUENCY
\RCLKSECOND)
77)
(LOCF (fetch DLMOUSETIMER of \MISCSTATS))
(QUOTE TICKS))
(SETQ \TIMER.INTERRUPT.PENDING T)))))
(\PERIODIC.INTERRUPTFRAME
(LAMBDA NIL
(DECLARE (GLOBALVARS \PERIODIC.INTERRUPT)) (* lmm "16-Jul-85 16:22")
(LET ((FN \PERIODIC.INTERRUPT))
(AND FN (SPREADAPPLY* FN)))))
)
(RPAQ? \KEYBUFFERING )
(RPAQ? \PERIODIC.INTERRUPT )
(RPAQ? \TIMER.INTERRUPT.PENDING )
(RPAQ? \PERIODIC.INTERRUPT.FREQUENCY 77)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(* cursor and mouse related functions.)
(DEFINEQ
(\HARDCURSORUP
(LAMBDA (NEWCURSOR INVERTFLG) (* gbn: "26-Jan-86 17:23")
(* version of \CURSORUP that knows about the
possibility of the cursor being on the color screen.)
(PROG (IMAGE)
(SETQ \SOFTCURSORP NIL)
(SETQ \CURRENTCURSOR NEWCURSOR)
(SETQ IMAGE (fetch (CURSOR CUIMAGE) of NEWCURSOR))
(COND
((NOT (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of IMAGE)
(fetch (BITMAP BITMAPBITSPERPIXEL) of \CURSORDESTINATION)))
(\CURSORBITSPERPIXEL NEWCURSOR (fetch (BITMAP BITMAPBITSPERPIXEL) of
\CURSORDESTINATION))
(SETQ IMAGE (fetch (CURSOR CUIMAGE) of NEWCURSOR))))
(BITBLT IMAGE 0 0 CursorBitMap 0 (IDIFFERENCE HARDCURSORHEIGHT (fetch (BITMAP
BITMAPHEIGHT)
of IMAGE))
HARDCURSORWIDTH HARDCURSORHEIGHT (COND
(INVERTFLG (QUOTE INVERT))
(T (QUOTE INPUT)))
(QUOTE REPLACE))
(COND
((EQ \MACHINETYPE \DAYBREAK)
(\DoveDisplay.SetCursorShape CursorBitMap))))))
(\HARDCURSORPOSITION
(LAMBDA (XPOS YPOS) (* kbr: "13-Jun-85 21:24")
(* sets cursor position, adjusts for hotspot and tty
region limits. XPOS and YPOS are the screen
coordinates of the hotspot location.)
(DECLARE (GLOBALVARS \CURSORHOTSPOTX \CURSORHOTSPOTY \CURSORDESTWIDTH \CURSORDESTHEIGHT))
(* YPOS is reflected around CURSORYMAX because the
screen has (0,0) as the upper left corner.
*)
(SETQ YPOS (IDIFFERENCE (SUB1 \CURSORDESTHEIGHT)
YPOS)) (* Clip coordinates *)
(SETQ XPOS (UNSIGNED (IDIFFERENCE (COND
((ILESSP XPOS 0)
0)
((IGEQ XPOS \CURSORDESTWIDTH)
(SUB1 \CURSORDESTWIDTH))
(T XPOS))
\CURSORHOTSPOTX)
BITSPERWORD))
(SETQ YPOS (UNSIGNED (IDIFFERENCE (COND
((ILESSP YPOS 0)
0)
((IGEQ YPOS \CURSORDESTHEIGHT)
(SUB1 \CURSORDESTHEIGHT))
(T YPOS))
\CURSORHOTSPOTY)
BITSPERWORD))
(COND
((EQ \MACHINETYPE \DANDELION) (* Temporary workaround)
(COND
((IGREATERP YPOS 32767)
(SETQ YPOS 0)))
(COND
((IGREATERP XPOS 32767)
(SETQ XPOS 0)))))
(\SETMOUSEXY XPOS YPOS)
(PROGN (* change the cursor position too so that
GETMOUSESTATE will get the correct values if it is
called before the next 60 cycle interrupt.)
(\PUTBASE \EM.CURSORX 0 XPOS)
(\PUTBASE \EM.CURSORY 0 YPOS))
NIL))
(\HARDCURSORDOWN
(LAMBDA NIL (* kbr: "23-Apr-85 18:26")
(\CLEARBM (CURSORBITMAP))))
)
(DEFINEQ
(CURSOR.INIT
(LAMBDA NIL (* kbr: "23-Jan-86 17:34")
(PROG (DESTBPL) (* Assorted globals for doing the color cursor.
*)
(SETQ \CURSORDESTINATION ScreenBitMap)
(SETQ \SOFTCURSORUPBM NIL)
(SETQ \SOFTCURSORDOWNBM NIL)
(SETQ \CURSORDESTLINE 0)
(SETQ \CURSORDESTLINEBASE (fetch (BITMAP BITMAPBASE) of ScreenBitMap))
(SETQ \CURSORDESTWIDTH (fetch (BITMAP BITMAPWIDTH) of ScreenBitMap))
(SETQ \CURSORDESTHEIGHT (fetch (BITMAP BITMAPHEIGHT) of ScreenBitMap))
(SETQ \CURSORDESTRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of ScreenBitMap))
(* Initialize PILOTBBTs. *)
(SETQ DESTBPL (UNFOLD \CURSORDESTRASTERWIDTH BITSPERWORD))
(* These PILOTBBTs are the mixing areas for forming
the color cursor image. *)
(* Does SCREEN to DOWNBM via INPUT, REPLACE.
*)
(SETQ \SOFTCURSORBBT1
(create PILOTBBT
PBTSOURCEBPL ← DESTBPL
PBTDISJOINT ← T
PBTSOURCETYPE ← 0
PBTOPERATION ← 0))
(\LOCKCELL \SOFTCURSORBBT1) (* Does DOWNBM to UPBM via INPUT, REPLACE.
*)
(SETQ \SOFTCURSORBBT2
(create PILOTBBT
PBTDESTBIT ← 0
PBTSOURCEBIT ← 0
PBTDISJOINT ← T
PBTSOURCETYPE ← 0
PBTOPERATION ← 0))
(\LOCKCELL \SOFTCURSORBBT2) (* Does MASK to UPBM via INPUT, ERASE.
*)
(SETQ \SOFTCURSORBBT3
(create PILOTBBT
PBTDESTBIT ← 0
PBTSOURCEBIT ← 0
PBTDISJOINT ← T
PBTSOURCETYPE ← 1
PBTOPERATION ← 1))
(\LOCKCELL \SOFTCURSORBBT3) (* Does IMAGE to UPBM via INPUT, PAINT.
*)
(SETQ \SOFTCURSORBBT4
(create PILOTBBT
PBTDESTBIT ← 0
PBTSOURCEBIT ← 0
PBTDISJOINT ← T
PBTSOURCETYPE ← 0
PBTOPERATION ← 2))
(\LOCKCELL \SOFTCURSORBBT4) (* Does UPBM to SCREEN via INPUT, REPLACE.
*)
(SETQ \SOFTCURSORBBT5
(create PILOTBBT
PBTDESTBPL ← DESTBPL
PBTDISJOINT ← T
PBTSOURCETYPE ← 0
PBTOPERATION ← 0))
(\LOCKCELL \SOFTCURSORBBT5) (* Does DOWNBM to SCREEN via INPUT, REPLACE.
*)
(SETQ \SOFTCURSORBBT6
(create PILOTBBT
PBTDESTBPL ← DESTBPL
PBTDISJOINT ← T
PBTSOURCETYPE ← 0
PBTOPERATION ← 0))
(\LOCKCELL \SOFTCURSORBBT6) (* Lock things down. *)
)))
(\CURSORDESTINATION
(LAMBDA (DESTINATION) (* kbr: " 2-Sep-85 20:13")
(* Change DESTINATION of \CURRENTCURSOR, assuming it
is down. *)
(PROG (DESTBPL)
(COND
((NOT (EQ DESTINATION \CURSORDESTINATION))
(UNINTERRUPTABLY
(COND
((NOT (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of (fetch (CURSOR
CUIMAGE)
of \CURRENTCURSOR))
(fetch (BITMAP BITMAPBITSPERPIXEL) of DESTINATION)))
(\CURSORBITSPERPIXEL \CURRENTCURSOR (fetch (BITMAP BITMAPBITSPERPIXEL)
of DESTINATION))))
(\SETMOUSEXY 0 0)
(\PUTBASE \EM.CURSORX 0 0)
(\PUTBASE \EM.CURSORY 0 0)
(SETQ \CURSORDESTLINE 0)
(SETQ.NOREF \CURSORDESTLINEBASE (fetch (BITMAP BITMAPBASE) of DESTINATION))
(SETQ \CURSORDESTWIDTH (fetch (BITMAP BITMAPWIDTH) of DESTINATION))
(SETQ \CURSORDESTHEIGHT (fetch (BITMAP BITMAPHEIGHT) of DESTINATION))
(SETQ \CURSORDESTRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of
DESTINATION))
(SETQ DESTBPL (UNFOLD \CURSORDESTRASTERWIDTH BITSPERWORD))
(replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT1 with DESTBPL)
(replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT5 with DESTBPL)
(replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT6 with DESTBPL)
(SETQ \CURSORDESTINATION DESTINATION)))))))
(\SOFTCURSORUP
(LAMBDA (NEWCURSOR) (* kbr: " 2-Sep-85 20:15")
(* Put soft NEWCURSOR up, assuming soft cursor is
down. *)
(PROG (IMAGE MASK WIDTH BWIDTH HEIGHT CURSORBITSPERPIXEL CURSORBPL UPBMBASE DOWNBMBASE)
(* Get cursor IMAGE & MASK.
*)
(SETQ IMAGE (fetch (CURSOR CUIMAGE) of NEWCURSOR))
(SETQ MASK (fetch (CURSOR CUMASK) of NEWCURSOR))
(SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of IMAGE))
(SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of IMAGE))
(SETQ CURSORBITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of IMAGE))
(* Create new UPBM & DOWNBM caches if necessary.
*)
(COND
((NOT (AND (type? BITMAP \SOFTCURSORUPBM)
(EQ (fetch (BITMAP BITMAPWIDTH) of \SOFTCURSORUPBM)
WIDTH)
(EQ (fetch (BITMAP BITMAPHEIGHT) of \SOFTCURSORUPBM)
HEIGHT)
(EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of \SOFTCURSORUPBM)
CURSORBITSPERPIXEL)))
(SETQ \SOFTCURSORWIDTH WIDTH)
(SETQ \SOFTCURSORHEIGHT HEIGHT)
(SETQ \SOFTCURSORUPBM (BITMAPCREATE WIDTH HEIGHT CURSORBITSPERPIXEL))
(SETQ \SOFTCURSORDOWNBM (BITMAPCREATE WIDTH HEIGHT CURSORBITSPERPIXEL))
(SETQ UPBMBASE (fetch (BITMAP BITMAPBASE) of \SOFTCURSORUPBM))
(\TEMPLOCKPAGES UPBMBASE 1)
(SETQ DOWNBMBASE (fetch (BITMAP BITMAPBASE) of \SOFTCURSORDOWNBM))
(\TEMPLOCKPAGES DOWNBMBASE 1)
(SETQ CURSORBPL (UNFOLD (fetch (BITMAP BITMAPRASTERWIDTH) of IMAGE)
BITSPERWORD))
(SETQ BWIDTH (ITIMES (fetch (BITMAP BITMAPWIDTH) of IMAGE)
(fetch (BITMAP BITMAPBITSPERPIXEL) of IMAGE)))
(replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT1 with CURSORBPL)
(replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT2 with UPBMBASE)
(replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT2 with CURSORBPL)
(replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT2 with DOWNBMBASE)
(replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT2 with CURSORBPL)
(replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT2 with BWIDTH)
(replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT2 with HEIGHT)
(replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT3 with UPBMBASE)
(replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT3 with CURSORBPL)
(replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT3 with CURSORBPL)
(replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT3 with BWIDTH)
(replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT3 with HEIGHT)
(replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT4 with UPBMBASE)
(replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT4 with CURSORBPL)
(replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT4 with CURSORBPL)
(replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT4 with BWIDTH)
(replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT4 with HEIGHT)
(replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT5 with CURSORBPL)
(replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT6 with CURSORBPL)))
(* Change PILOTBBTs. *)
(replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT3 with (fetch (BITMAP BITMAPBASE)
of MASK))
(replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT4 with (fetch (BITMAP BITMAPBASE)
of IMAGE))
(* Put up new \CURRENTCURSOR.
*)
(SETQ \CURRENTCURSOR NEWCURSOR)
(\TEMPLOCKPAGES \CURRENTCURSOR 1)
(SETQ \SOFTCURSORP T)
(\SOFTCURSORUPCURRENT))))
(\SOFTCURSORUPCURRENT
(LAMBDA NIL (* kbr: "18-Aug-85 15:09")
(* Put soft \CURRENTCURSOR up, assuming soft cursor is
down. *)
(PROG (DISPINTERRUPT X Y XBASE YBASE WIDTH HEIGHT BITSPERPIXEL MINUSDESTRASTERWIDTH DEST
DESTBIT SOURCEOFFSET UPBMSOURCE DOWNBMSOURCE SOURCEBIT)
(SETQ DISPINTERRUPT (\GETBASE \EM.DISPINTERRUPT 0))
(\PUTBASE \EM.DISPINTERRUPT 0 0)
(SETQ \SOFTCURSORUPP T) (* Roughly, we want to (BITBLT CURSOR XBASE YBASE
SCREEN X Y WIDTH HEIGHT) *)
(SETQ X (SIGNED (\GETBASE \EM.MOUSEX 0)
BITSPERWORD))
(SETQ Y (SIGNED (\GETBASE \EM.MOUSEY 0)
BITSPERWORD))
(SETQ XBASE 0)
(SETQ YBASE 0)
(SETQ WIDTH \SOFTCURSORWIDTH)
(SETQ HEIGHT \SOFTCURSORHEIGHT) (* Clip off screen parts of cursor.
*)
(COND
((IGREATERP 0 X) (* Some of cursor is to left of screen.
*)
(SETQ XBASE (IMINUS X))
(SETQ WIDTH (IDIFFERENCE WIDTH XBASE))
(SETQ X 0))
((IGREATERP (IPLUS X WIDTH)
\CURSORDESTWIDTH) (* Some of cursor is to right of screen.
*)
(SETQ WIDTH (IDIFFERENCE \CURSORDESTWIDTH X))))
(COND
((ILESSP WIDTH 0)
(GO EXIT)))
(COND
((IGREATERP 0 Y) (* Some of cursor is to above of screen.
*)
(SETQ YBASE (IMINUS Y))
(SETQ HEIGHT (IDIFFERENCE HEIGHT YBASE))
(SETQ Y 0))
((IGREATERP (IPLUS Y HEIGHT)
\CURSORDESTHEIGHT) (* Some of cursor is to below of screen.
*)
(SETQ HEIGHT (IDIFFERENCE \CURSORDESTHEIGHT Y))))
(COND
((ILESSP HEIGHT 0)
(GO EXIT))) (* These loops reset \CURSORDESTLINEBASE while
avoiding large number arithmetic.
*)
(COND
((IGREATERP \CURSORDESTLINE Y)
(SETQ MINUSDESTRASTERWIDTH (IMINUS \CURSORDESTRASTERWIDTH))
(until (EQ \CURSORDESTLINE Y)
do (SETQ \CURSORDESTLINE (SUB1 \CURSORDESTLINE))
(SETQ.NOREF \CURSORDESTLINEBASE (\ADDBASE \CURSORDESTLINEBASE
MINUSDESTRASTERWIDTH))))
((ILESSP \CURSORDESTLINE Y)
(until (EQ \CURSORDESTLINE Y)
do (SETQ \CURSORDESTLINE (ADD1 \CURSORDESTLINE))
(SETQ.NOREF \CURSORDESTLINEBASE (\ADDBASE \CURSORDESTLINEBASE
\CURSORDESTRASTERWIDTH)))))
(* Reset PILOTBBTs. *)
(SETQ BITSPERPIXEL (fetch (CURSOR CUBITSPERPIXEL) of \CURRENTCURSOR))
(SETQ X (ITIMES BITSPERPIXEL X))
(SETQ XBASE (ITIMES BITSPERPIXEL XBASE))
(SETQ WIDTH (ITIMES BITSPERPIXEL WIDTH))
(SETQ DEST \CURSORDESTLINEBASE)
(SETQ DESTBIT X)
(SETQ SOURCEOFFSET (ITIMES YBASE (fetch (BITMAP BITMAPRASTERWIDTH) of
\SOFTCURSORUPBM)))
(SETQ UPBMSOURCE (\ADDBASE (fetch (BITMAP BITMAPBASE) of \SOFTCURSORUPBM)
SOURCEOFFSET))
(SETQ DOWNBMSOURCE (\ADDBASE (fetch (BITMAP BITMAPBASE) of \SOFTCURSORDOWNBM)
SOURCEOFFSET))
(SETQ SOURCEBIT XBASE)
(* TBW: Most of these fields only need to be set if we are clipping this time or the previous time we put the
cursor up. *)
(replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT1 with DOWNBMSOURCE)
(replace (PILOTBBT PBTDESTBIT) of \SOFTCURSORBBT1 with SOURCEBIT)
(replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT1 with DEST)
(replace (PILOTBBT PBTSOURCEBIT) of \SOFTCURSORBBT1 with DESTBIT)
(replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT1 with WIDTH)
(replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT1 with HEIGHT)
(replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT5 with DEST)
(replace (PILOTBBT PBTDESTBIT) of \SOFTCURSORBBT5 with DESTBIT)
(replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT5 with UPBMSOURCE)
(replace (PILOTBBT PBTSOURCEBIT) of \SOFTCURSORBBT5 with SOURCEBIT)
(replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT5 with WIDTH)
(replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT5 with HEIGHT)
(replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT6 with DEST)
(replace (PILOTBBT PBTDESTBIT) of \SOFTCURSORBBT6 with DESTBIT)
(replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT6 with DOWNBMSOURCE)
(replace (PILOTBBT PBTSOURCEBIT) of \SOFTCURSORBBT6 with SOURCEBIT)
(replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT6 with WIDTH)
(replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT6 with HEIGHT)
(* Save background behind cursor.
*)
(\PILOTBITBLT \SOFTCURSORBBT1 0) (* Compute cursor appearance.
UPBM = (OR IMAGE (AND DOWNBM
(NOT MASK))) *)
(\PILOTBITBLT \SOFTCURSORBBT2 0)
(\PILOTBITBLT \SOFTCURSORBBT3 0)
(\PILOTBITBLT \SOFTCURSORBBT4 0) (* Put color cursor up. *)
(\SOFTCURSORPILOTBITBLT \SOFTCURSORBBT5 0)
EXIT(\PUTBASE \EM.DISPINTERRUPT 0 DISPINTERRUPT))))
(\SOFTCURSORPOSITION
(LAMBDA (X Y) (* kbr: "18-Aug-85 14:50")
(* Move soft cursor. *)
(PROG (DISPINTERRUPT)
(SETQ DISPINTERRUPT (\GETBASE \EM.DISPINTERRUPT 0))
(\PUTBASE \EM.DISPINTERRUPT 0 0)
(COND
((OR (NOT (EQ (\GETBASE \EM.CURSORX 0)
X))
(NOT (EQ (\GETBASE \EM.CURSORY 0)
Y)))
(COND
(\SOFTCURSORUPP (\SOFTCURSORDOWN)
(\SOFTCURSORUPCURRENT)))))
(\PUTBASE \EM.DISPINTERRUPT 0 DISPINTERRUPT))))
(\SOFTCURSORDOWN
(LAMBDA NIL (* kbr: " 6-Jul-85 00:09")
(* Take COLOR cursor down. *)
(PROG (DISPINTERRUPT) (* \SOFTCURSORUPP must be set to NIL before BITBLTing.
*)
(SETQ DISPINTERRUPT (\GETBASE \EM.DISPINTERRUPT 0))
(\PUTBASE \EM.DISPINTERRUPT 0 0)
(SETQ \SOFTCURSORUPP NIL)
(\SOFTCURSORPILOTBITBLT \SOFTCURSORBBT6 0)
(\PUTBASE \EM.DISPINTERRUPT 0 DISPINTERRUPT))))
(CURSORPROP
(LAMBDA X (* kbr: "11-Jan-86 20:03")
(COND
((IGREATERP X 2)
(PUTCURSORPROP (ARG X 1)
(ARG X 2)
(ARG X 3)))
((EQ X 2)
(GETCURSORPROP (ARG X 1)
(ARG X 2)))
(T (\ILLEGAL.ARG NIL)))))
(GETCURSORPROP
(LAMBDA (CURSOR PROP) (* kbr: "26-Apr-85 11:18")
(LISTGET (fetch (CURSOR CUDATA) of CURSOR)
PROP)))
(PUTCURSORPROP
(LAMBDA (CURSOR PROP VALUE) (* kbr: "26-Apr-85 11:18")
(PROG (OLDDATA OLDVALUE)
(SETQ OLDDATA (fetch (CURSOR CUDATA) of CURSOR))
(COND
(OLDDATA (SETQ OLDVALUE (LISTGET OLDDATA PROP))
(COND
(VALUE (LISTPUT OLDDATA PROP VALUE))
(OLDVALUE (COND
((EQ (CAR OLDDATA)
PROP)
(replace (CURSOR CUDATA) of CURSOR
with (CDDR (fetch (CURSOR CUDATA) of CURSOR))))
(T (FOR TAIL ON (CDR OLDDATA) BY (CDDR TAIL)
WHEN (EQ (CADR TAIL)
PROP)
DO (FRPLACD TAIL (CDDDR TAIL))
(RETURN)))))))
(VALUE (replace (CURSOR CUDATA) of CURSOR with (LIST PROP VALUE))))
(RETURN OLDVALUE))))
(\CURSORBITSPERPIXEL
(LAMBDA (CURSOR NEWBITSPERPIXEL) (* kbr: "12-May-85 17:15")
(* Swap in NEWBITSPERPIXEL IMAGE and MASK, creating
them if necessary. *)
(PROG (OLDBITSPERPIXEL OLDIMAGE OLDMASK WHITE BLACK NEWIMAGE NEWMASK)
(SETQ OLDBITSPERPIXEL (fetch (CURSOR CUBITSPERPIXEL) of CURSOR))
(COND
((EQ OLDBITSPERPIXEL NEWBITSPERPIXEL)
(RETURN))) (* Save OLDIMAGE and OLDMASK.
*)
(SETQ OLDIMAGE (fetch (CURSOR CUIMAGE) of CURSOR))
(SETQ OLDMASK (fetch (CURSOR CUMASK) of CURSOR))
(CURSORPROP CURSOR (\CURSORIMAGEPROPNAME OLDBITSPERPIXEL)
OLDIMAGE)
(CURSORPROP CURSOR (\CURSORMASKPROPNAME OLDBITSPERPIXEL)
OLDMASK) (* Unsave NEWIMAGE and NEWMASK if possible, otherwise
create them. *)
(COND
((SETQ NEWIMAGE (CURSORPROP CURSOR (\CURSORIMAGEPROPNAME NEWBITSPERPIXEL)))
(* Use cached NEWIMAGE & NEWMASK.
*)
(SETQ NEWMASK (CURSORPROP CURSOR (\CURSORMASKPROPNAME NEWBITSPERPIXEL))))
(T (* Create NEWIMAGE & NEWMASK.
*)
(SETQ WHITE (MASK.1'S 0 NEWBITSPERPIXEL))
(SETQ BLACK 0)
(SETQ NEWIMAGE (COLORIZEBITMAP (CURSORPROP CURSOR (QUOTE IMAGE1))
BLACK WHITE NEWBITSPERPIXEL))
(SETQ NEWMASK (COLORIZEBITMAP (CURSORPROP CURSOR (QUOTE MASK1))
BLACK WHITE NEWBITSPERPIXEL))))
(replace (CURSOR CUIMAGE) of CURSOR with NEWIMAGE)
(replace (CURSOR CUMASK) of CURSOR with NEWMASK))))
(\CURSORIMAGEPROPNAME
(LAMBDA (BITSPERPIXEL) (* kbr: "26-Apr-85 11:18")
(SELECTQ BITSPERPIXEL
(1 (QUOTE IMAGE1))
(4 (QUOTE IMAGE4))
(8 (QUOTE IMAGE8))
(SHOULDNT))))
(\CURSORMASKPROPNAME
(LAMBDA (BITSPERPIXEL) (* kbr: "26-Apr-85 11:18")
(SELECTQ BITSPERPIXEL
(1 (QUOTE MASK1))
(4 (QUOTE MASK4))
(8 (QUOTE MASK8))
(SHOULDNT))))
)
(DEFINEQ
(CURSORCREATE
(LAMBDA (IMAGE MASK HOTSPOTX HOTSPOTY DATA) (* gbn: "26-Jan-86 17:05")
(* creates a cursor from a bitmap.
HOTSPOTX and HOTSPOTY specify the hotspot.)
(* * If Mask is a fixp then we presume this is the old arg list (bitmap x y). the cursor filepkgtype has been
changed to write the new arg list. The other is provided for (dubious) compatibility)
(PROG (CURSOR)
(COND
((OR (FIXP MASK)
(POSITIONP MASK))
(SETQ HOTSPOTY HOTSPOTX)
(SETQ HOTSPOTX MASK)
(SETQ MASK NIL)))
(COND
((POSITIONP HOTSPOTX)
(SETQ HOTSPOTY (fetch (POSITION YCOORD) of HOTSPOTX))
(SETQ HOTSPOTX (fetch (POSITION XCOORD) of HOTSPOTX))))
(SETQ CURSOR (create CURSOR
CUIMAGE ← IMAGE
CUMASK ← (OR MASK IMAGE)
CUHOTSPOTX ← (OR (FIXP HOTSPOTX)
0)
CUHOTSPOTY ← (OR (FIXP HOTSPOTY)
(SUB1 (BITMAPHEIGHT IMAGE)))
CUDATA ← DATA))
(RETURN CURSOR))))
(CURSOR
(LAMBDA (NEWCURSOR INVERTFLG) (* kbr: "13-Jun-85 20:45")
(* installs NEWCURSOR as the cursor and returns the
current cursor state. If INVERTFLG is non-NIL, the
cursor image is inverted during installation.)
(DECLARE (GLOBALVARS DEFAULTCURSOR))
(PROG (OLDCURSOR)
(SETQ OLDCURSOR \CURRENTCURSOR)
(COND
((EQ NEWCURSOR T)
(SETQ NEWCURSOR DEFAULTCURSOR)))
(COND
((type? CURSOR NEWCURSOR)
(\CURSORDOWN)
(\CURSORUP NEWCURSOR INVERTFLG) (* set after adjustment to avoid confusion about
hotspot during adjustment.)
(SETQ \CURSORHOTSPOTX (fetch (CURSOR CUHOTSPOTX) of NEWCURSOR))
(SETQ \CURSORHOTSPOTY (IDIFFERENCE (SUB1 (fetch (BITMAP BITMAPHEIGHT)
of (fetch (CURSOR CUIMAGE)
of NEWCURSOR)))
(fetch (CURSOR CUHOTSPOTY) of NEWCURSOR))
)))
(RETURN OLDCURSOR))))
(\CURSORUP
(LAMBDA (NEWCURSOR INVERTFLG) (* kbr: "18-Aug-85 14:38")
(UNINTERRUPTABLY
(\CURSORBITSPERPIXEL NEWCURSOR (fetch (BITMAP BITMAPBITSPERPIXEL) of \CURSORDESTINATION)
)
(COND
((AND (EQ (fetch (CURSOR CUIMAGE) of NEWCURSOR)
(fetch (CURSOR CUMASK) of NEWCURSOR))
(ILEQ (fetch (BITMAP BITMAPWIDTH) of (fetch (CURSOR CUIMAGE)
of NEWCURSOR))
HARDCURSORWIDTH)
(ILEQ (fetch (BITMAP BITMAPHEIGHT) of (fetch (CURSOR CUIMAGE)
of NEWCURSOR))
HARDCURSORHEIGHT)
(EQ \CURSORDESTINATION ScreenBitMap))
(\HARDCURSORUP NEWCURSOR INVERTFLG))
(T (\SOFTCURSORUP NEWCURSOR)))
(ADJUSTCURSORPOSITION (IDIFFERENCE \CURSORHOTSPOTX (fetch (CURSOR CUHOTSPOTX)
of NEWCURSOR))
(IDIFFERENCE (IDIFFERENCE (SUB1 (fetch (BITMAP BITMAPHEIGHT)
of (fetch (CURSOR
CUIMAGE)
of NEWCURSOR)))
(fetch (CURSOR CUHOTSPOTY)
of NEWCURSOR))
\CURSORHOTSPOTY)))))
(\CURSORPOSITION
(LAMBDA (XPOS YPOS) (* kbr: "19-Jan-86 16:17")
(* sets cursor position, adjusts for hotspot and tty
region limits. XPOS and YPOS are the screen
coordinates of the hotspot location.)
(DECLARE (GLOBALVARS \CURSORHOTSPOTX \CURSORHOTSPOTY \CURSORDESTWIDTH \CURSORDESTHEIGHT))
(* YPOS is reflected around CURSORYMAX because the
screen has (0,0) as the upper left corner.
*)
(SETQ YPOS (IDIFFERENCE (SUB1 \CURSORDESTHEIGHT)
YPOS)) (* Clip coordinates *)
(SETQ XPOS (UNSIGNED (IDIFFERENCE (COND
((ILESSP XPOS 0)
0)
((IGEQ XPOS \CURSORDESTWIDTH)
(SUB1 \CURSORDESTWIDTH))
(T XPOS))
\CURSORHOTSPOTX)
BITSPERWORD))
(SETQ YPOS (UNSIGNED (IDIFFERENCE (COND
((ILESSP YPOS 0)
0)
((IGEQ YPOS \CURSORDESTHEIGHT)
(SUB1 \CURSORDESTHEIGHT))
(T YPOS))
\CURSORHOTSPOTY)
BITSPERWORD))
(COND
((EQ \MACHINETYPE \DANDELION) (* Temporary workaround)
(COND
((IGREATERP YPOS 32767)
(SETQ YPOS 0)))
(COND
((IGREATERP XPOS 32767)
(SETQ XPOS 0)))))
(\SETMOUSEXY XPOS YPOS)
(COND
(\SOFTCURSORP (\SOFTCURSORPOSITION XPOS YPOS)))
(PROGN (* change the cursor position too so that
GETMOUSESTATE will get the correct values if it is
called before the next 60 cycle interrupt.)
(\PUTBASE \EM.CURSORX 0 XPOS)
(\PUTBASE \EM.CURSORY 0 YPOS)
(COND
((EQ \MACHINETYPE \DAYBREAK) (* Need to notify DAYBREAK IOP to move cursor.
*)
(\DoveDisplay.SetCursorPosition XPOS YPOS))))
NIL))
(\CURSORDOWN
(LAMBDA NIL (* kbr: "12-Jun-85 17:21")
(UNINTERRUPTABLY
(COND
(\SOFTCURSORP (\SOFTCURSORDOWN))
(T (\HARDCURSORDOWN))))))
(ADJUSTCURSORPOSITION
(LAMBDA (DELTAX DELTAY) (* kbr: " 6-Jan-86 11:55")
(COND
((POSITIONP DELTAX)
(\CURSORPOSITION (IPLUS (fetch (POSITION XCOORD) of DELTAX)
(\XMOUSECOORD))
(IPLUS (fetch (POSITION YCOORD) of DELTAX)
(\YMOUSECOORD))))
(T (\CURSORPOSITION (IPLUS (OR DELTAX 0)
(\XMOUSECOORD))
(IPLUS (OR DELTAY 0)
(\YMOUSECOORD)))))))
(CURSORPOSITION
(LAMBDA (NEWPOSITION DISPLAYSTREAM OLDPOSITION) (* kbr:
"13-Feb-86 15:53")
(PROG (DD)
(SETQ DD (\GETDISPLAYDATA DISPLAYSTREAM))
(OR (type? POSITION OLDPOSITION)
(SETQ OLDPOSITION (create POSITION)))
(freplace (POSITION XCOORD) of OLDPOSITION with (\DSPUNTRANSFORMX (\XMOUSECOORD
)
DD))
(freplace (POSITION YCOORD) of OLDPOSITION with (\DSPUNTRANSFORMY (\YMOUSECOORD
)
DD))
(COND
((type? POSITION NEWPOSITION)
(\CURSORPOSITION (\DSPTRANSFORMX (fetch (POSITION XCOORD) of NEWPOSITION)
DD)
(\DSPTRANSFORMY (fetch (POSITION YCOORD) of NEWPOSITION)
DD)))
((type? SCREENPOSITION NEWPOSITION)
(CURSORSCREEN (fetch (SCREENPOSITION SCREEN) of NEWPOSITION)
(fetch (SCREENPOSITION XCOORD) of NEWPOSITION)
(fetch (SCREENPOSITION YCOORD) of NEWPOSITION)))
(NEWPOSITION (\ILLEGAL.ARG NEWPOSITION)))
(RETURN OLDPOSITION))))
(CURSORSCREEN
(LAMBDA (SCREEN XCOORD YCOORD) (* gbn:
"25-Jan-86 16:53")
(* * sets up SCREEN to be the current screen, XCOORD , YCOORD is initial
pos of cursor on SCREEN)
(COND
((NULL XCOORD)
(SETQ XCOORD 0)))
(COND
((NULL YCOORD)
(SETQ YCOORD 0)))
(PROG (DESTINATION)
(SETQ DESTINATION (fetch (SCREEN SCDESTINATION) of SCREEN))
(\CURSORDOWN)
(SETQ \CURSORSCREEN SCREEN)
(\CURSORDESTINATION DESTINATION)
(\CURSORUP \CURRENTCURSOR)
(\CURSORPOSITION XCOORD YCOORD))))
(CURSOREXIT
(LAMBDA NIL (* gbn:
"25-Jan-86 16:52")
(* * called when cursor moves off the screen edge)
(DECLARE (GLOBALVARS LASTSCREEN LASTMOUSEX LASTMOUSEY))
(PROG (SCREEN XCOORD YCOORD SCREEN2 XCOORD2 YCOORD2)
(SETQ SCREEN LASTSCREEN)
(SETQ XCOORD LASTMOUSEX)
(SETQ YCOORD LASTMOUSEY)
(SETQ SCREEN2 (COND
((EQ SCREEN \MAINSCREEN)
\COLORSCREEN)
(T \MAINSCREEN))) (* generalize for more
than two screens
(or alternate physical
arrangement of screens.))
(COND
((EQ XCOORD 0)
(SETQ XCOORD2 (IDIFFERENCE (fetch (SCREEN SCWIDTH) of SCREEN2)
2)))
((EQ XCOORD (SUB1 (fetch (SCREEN SCWIDTH) of SCREEN)))
(SETQ XCOORD2 1))
(T (RETURN)))
(SETQ YCOORD2 (IQUOTIENT (ITIMES YCOORD (SUB1 (fetch (SCREEN SCHEIGHT) of SCREEN2))
)
(SUB1 (fetch (SCREEN SCHEIGHT) of SCREEN))))
(CURSORSCREEN SCREEN2 XCOORD2 YCOORD2))))
(FLIPCURSOR
(LAMBDA NIL (* gbn: "26-Jan-86 17:13")
(PROG (ADDR)
(COND
((NOT \SOFTCURSORP)
(SETQ ADDR \EM.CURSORBITMAP)
(FRPTQ HARDCURSORHEIGHT (\PUTBASE ADDR 0 (LOGXOR (\GETBASE ADDR 0)
(CONSTANT
(SUB1 (EXPT 2
HARDCURSORWIDTH)))))
(SETQ ADDR (\ADDBASE ADDR 1)))
(COND
((EQ \MACHINETYPE \DAYBREAK)
(\DoveDisplay.SetCursorShape))))))))
(FLIPCURSORBAR
(LAMBDA (N) (* kbr: " 4-Sep-85 14:53")
(* * Inverts the Nth line of the cursor, N = 0 being the top)
(COND
((NOT \SOFTCURSORP)
(\PUTBASE \EM.CURSORBITMAP N (LOGXOR (\GETBASE \EM.CURSORBITMAP N)
MAX.SMALLP))
(COND
((EQ \MACHINETYPE \DAYBREAK) (* Notify IOP)
(\DoveDisplay.SetCursorShape)))))))
(LASTMOUSEX
(LAMBDA (DS) (* rmk: "30-AUG-83 13:07")
(* returns the mouse x position in the coordinates of
the DisplayStream DS)
(\DSPUNTRANSFORMX LASTMOUSEX (\GETDISPLAYDATA DS))))
(LASTMOUSEY
(LAMBDA (DS) (* rmk: "30-AUG-83 13:07")
(* returns the mouse y position in the coordinates of
the DisplayStream DS)
(\DSPUNTRANSFORMY LASTMOUSEY (\GETDISPLAYDATA DS))))
(CREATEPOSITION
(LAMBDA (XCOORD YCOORD) (* rmk: " 6-Aug-84 13:43")
(create POSITION
XCOORD ← (OR XCOORD 0)
YCOORD ← (OR YCOORD 0))))
(POSITIONP
(LAMBDA (X) (* rrb "25-AUG-82 11:04")
(* is X a position? For now just a cons check but
should be made a datatype.)
(AND (LISTP X)
(NUMBERP (CAR X))
(NUMBERP (CDR X))
X)))
(CURSORHOTSPOT
(LAMBDA (NEWPOSITION) (* gbn: "26-Jan-86 15:36")
(* returns the current cursor hot spot and sets the
hot spot to NEWPOSITON if one is given.)
(PROG1 (create POSITION
XCOORD ← \CURSORHOTSPOTX
YCOORD ← \CURSORHOTSPOTY)
(COND
((POSITIONP NEWPOSITION)
(SETQ \CURSORHOTSPOTX (fetch (POSITION YCOORD) of NEWPOSITION))
(SETQ \CURSORHOTSPOTY (fetch (POSITION YCOORD) of NEWPOSITION)))))))
)
(PUTPROPS CURSORPROP ARGNAMES (NIL (CURSOR PROP {NEWVALUE}) . U))
(RPAQ? \CURSORHOTSPOTX 0)
(RPAQ? \CURSORHOTSPOTY 0)
(RPAQ? \CURRENTCURSOR NIL)
(RPAQ? \SOFTCURSORWIDTH NIL)
(RPAQ? \SOFTCURSORHEIGHT NIL)
(RPAQ? \SOFTCURSORP NIL)
(RPAQ? \SOFTCURSORUPP NIL)
(RPAQ? \SOFTCURSORUPBM NIL)
(RPAQ? \SOFTCURSORDOWNBM NIL)
(RPAQ? \SOFTCURSORBBT1 NIL)
(RPAQ? \SOFTCURSORBBT2 NIL)
(RPAQ? \SOFTCURSORBBT3 NIL)
(RPAQ? \SOFTCURSORBBT4 NIL)
(RPAQ? \SOFTCURSORBBT5 NIL)
(RPAQ? \SOFTCURSORBBT6 NIL)
(RPAQ? \CURSORSCREEN NIL)
(RPAQ? \CURSORDESTINATION NIL)
(RPAQ? \CURSORDESTHEIGHT 808)
(RPAQ? \CURSORDESTWIDTH 1024)
(RPAQ? \CURSORDESTRASTERWIDTH 64)
(RPAQ? \CURSORDESTLINE 0)
(RPAQ? \CURSORDESTLINEBASE NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \CURSORHOTSPOTX \CURSORHOTSPOTY \CURRENTCURSOR \SOFTCURSORWIDTH \SOFTCURSORHEIGHT
\SOFTCURSORP \SOFTCURSORUPP \SOFTCURSORUPBM \SOFTCURSORDOWNBM \SOFTCURSORBBT1 \SOFTCURSORBBT2
\SOFTCURSORBBT3 \SOFTCURSORBBT4 \SOFTCURSORBBT5 \SOFTCURSORBBT6 \CURSORDESTINATION
\CURSORDESTHEIGHT \CURSORDESTWIDTH \CURSORDESTRASTERWIDTH \CURSORDESTLINE \CURSORDESTLINEBASE)
)
(DEFINEQ
(GETMOUSESTATE
(LAMBDA NIL (* kbr: " 6-Jul-85 14:16")
(* Reads the current state of the mouse and keyboard)
(SETQ LASTMOUSEX (\XMOUSECOORD))
(SETQ LASTMOUSEY (\YMOUSECOORD))
(SETQ LASTMOUSEBUTTONS (LOGXOR (LOGAND (fetch (KEYBOARDEVENT WU) of \LASTKEYSTATE)
\MOUSE.ALLBITS)
\MOUSE.ALLBITS))
(SETQ LASTKEYBOARD (\EVENTKEYS))
(SETQ LASTSCREEN \CURSORSCREEN)
NIL))
(\EVENTKEYS
(LAMBDA NIL (* rmk: " 4-JUN-81 22:58")
(* Returns the state of the various keys that are
represented in mouse events)
(LOGOR (COND
((KEYDOWNP (QUOTE LOCK))
128)
(T 0))
(COND
((KEYDOWNP (QUOTE LSHIFT))
64)
(T 0))
(COND
((KEYDOWNP (QUOTE CTRL))
32)
(T 0))
(COND
((KEYDOWNP (QUOTE RSHIFT))
8)
(T 0))
(COND
((KEYDOWNP (QUOTE BLANK-TOP))
4)
(T 0))
(COND
((KEYDOWNP (QUOTE BLANK-MIDDLE))
2)
(T 0))
(COND
((KEYDOWNP (QUOTE BLANK-BOTTOM))
1)
(T 0)))))
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(RPAQQ HARDCURSORHEIGHT 16)
(RPAQQ HARDCURSORWIDTH 16)
(CONSTANTS (HARDCURSORHEIGHT 16)
(HARDCURSORWIDTH 16))
)
(DECLARE: EVAL@COMPILE
(ADDTOVAR GLOBALVARS LASTMOUSEX LASTMOUSEY LASTSCREEN LASTMOUSEBUTTONS LASTMOUSETIME LASTKEYBOARD)
)
(* END EXPORTED DEFINITIONS)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
[PUTPROPS \SETMOUSEXY MACRO ((XPOS YPOS)
(PROGN (SELECTC \MACHINETYPE
(\DANDELION (do (PROGN (replace (IOPAGE NEWMOUSEX)
of \IOPAGE with XPOS)
(replace (IOPAGE NEWMOUSEY)
of \IOPAGE with YPOS))
repeatuntil
(ILESSP (fetch (IOPAGE NEWMOUSESTATE)
of \IOPAGE)
32768))
(* smash position until mouse says it is not busy)
(replace (IOPAGE NEWMOUSEX)
of \IOPAGE with XPOS)
(replace (IOPAGE NEWMOUSEY)
of \IOPAGE with YPOS)
(replace (IOPAGE NEWMOUSESTATE)
of \IOPAGE with 32768))
(\DAYBREAK (\DoveMisc.SetMousePosition XPOS YPOS))
NIL)
(PROGN (\PUTBASE \EM.MOUSEX 0 XPOS)
(\PUTBASE \EM.MOUSEY 0 YPOS]
)
(* END EXPORTED DEFINITIONS)
(DECLARE: EVAL@COMPILE
[PUTPROPS \XMOUSECOORD MACRO (NIL (IPLUS \CURSORHOTSPOTX (SIGNED (\GETBASE \EM.CURSORX 0)
BITSPERWORD]
[PUTPROPS \YMOUSECOORD MACRO (NIL (IDIFFERENCE (SUB1 \CURSORDESTHEIGHT)
(IPLUS \CURSORHOTSPOTY (SIGNED (\GETBASE \EM.CURSORY 0)
BITSPERWORD]
)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(MOVD (QUOTE CURSOR)
(QUOTE SETCURSOR))
(MOVD (QUOTE \CURSORPOSITION)
(QUOTE \SETCURSORPOSITION))
(RPAQ \SFPosition (CREATEPOSITION))
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(BLOCKRECORD KEYBOARDEVENT
((W0 WORD)
(W1 WORD)
(W2 WORD)
(W3 WORD)
(WU WORD)
(W4 WORD)
(W5 WORD)
(TIME FIXP)
(MOUSESTATE BITS 3)
(1SHIFT FLAG)
(2SHIFT FLAG)
(LOCK FLAG)
(CTRL FLAG)
(META FLAG)
(FONT FLAG)
(USERMODE1 FLAG)
(USERMODE2 FLAG)
(USERMODE3 FLAG)
(NIL BITS 4)
(MOUSEX WORD)
(MOUSEY WORD))
(CREATE (\ALLOCBLOCK (FOLDHI \KEYBOARDEVENT.SIZE WORDSPERCELL)))
W0 ← ALLUP W1 ← ALLUP W2 ← ALLUP W3 ← ALLUP W4 ← ALLUP W5 ← ALLUP WU ← ALLUP MOUSESTATE
← \DLMOUSE.UP [ACCESSFNS KEYBOARDEVENT ((SIZE (INDEXF (fetch MOUSEY of DATUM)))
(SHIFT (OR (fetch (KEYBOARDEVENT 1SHIFT)
DATUM)
(fetch (KEYBOARDEVENT 2SHIFT)
DATUM)))
(SHIFTORLOCK (OR (fetch (KEYBOARDEVENT SHIFT)
DATUM)
(fetch (KEYBOARDEVENT LOCK)
DATUM]
LOCK ← (XKEYDOWNP (QUOTE LOCK))
TIME ← 0)
]
(DECLARE: EVAL@COMPILE
(RPAQ \KEYBOARDEVENT.FIRST NRINGINDEXWORDS)
(RPAQQ \KEYBOARDEVENT.SIZE 12)
(RPAQ \KEYBOARDEVENT.LAST (PLUS \KEYBOARDEVENT.FIRST (TIMES \KEYBOARDEVENT.SIZE 383)))
[CONSTANTS (\KEYBOARDEVENT.FIRST NRINGINDEXWORDS)
\KEYBOARDEVENT.SIZE
(\KEYBOARDEVENT.LAST (PLUS \KEYBOARDEVENT.FIRST (TIMES \KEYBOARDEVENT.SIZE 383]
)
)
(DEFINEQ
(MACHINETYPE
(LAMBDA NIL (* mpl "27-Jun-85 20:57")
(SELECTQ (fetch MachineType of \InterfacePage)
(4 (QUOTE DOLPHIN))
(5 (QUOTE DORADO))
(6 (QUOTE DANDELION))
(8 (* This is \DAYBREAK internally)
(QUOTE DOVE))
NIL)))
(SETMAINTPANEL
(LAMBDA (N) (* mpl "21-Jul-85 18:15")
(SELECTC \MACHINETYPE
(\DANDELION (replace DLMAINTPANEL of \IOPAGE with N))
(\DOLPHIN ((OPCODES MISC1 3)
(\DTEST N (QUOTE SMALLP))))
(\DAYBREAK ((OPCODES DOVEMISC 2)
(\DTEST N (QUOTE SMALLP))))
NIL)))
)
(* DLion beeper)
(DEFINEQ
(BEEPON
(LAMBDA (FREQ) (* MPL "27-Jul-85 21:48")
(SELECTC \MACHINETYPE
(\DANDELION (while (IGEQ (fetch DLBEEPCMD of \IOPAGE)
32768)
do (BLOCK))
(replace DLBEEPFREQ of \IOPAGE with (IQUOTIENT 1843200
(IMAX FREQ 29)))
(replace DLBEEPCMD of \IOPAGE with 32768))
(\DAYBREAK (\DoveMisc.BeepOn FREQ))
(PROGN NIL))
NIL))
(BEEPOFF
(LAMBDA NIL (* MPL "27-Jul-85 21:49")
(SELECTC \MACHINETYPE
(\DANDELION (while (IGEQ (fetch DLBEEPCMD of \IOPAGE)
32768)
do (BLOCK))
(replace DLBEEPCMD of \IOPAGE with 32769))
(\DAYBREAK (\DoveMisc.BeepOff))
(PROGN NIL))
NIL))
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \EM.MOUSEX \EM.MOUSEY \EM.CURSORX \EM.CURSORY \EM.UTILIN \EM.REALUTILIN \EM.KBDAD0
\EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3 \EM.KBDAD4 \EM.KBDAD5 \EM.DISPINTERRUPT \EM.DISPLAYHEAD
\EM.CURSORBITMAP \MACHINETYPE \DEFAULTKEYACTION \CURRENTKEYACTION \PERIODIC.INTERRUPT
\PERIODIC.INTERRUPT.FREQUENCY)
)
(* END EXPORTED DEFINITIONS)
(DEFINEQ
(WITHOUT-INTERRUPTS
(NLAMBDA (FORM) (* lmm "18-Apr-85 02:53")
(PROG (VAL)
(\KEYBOARDOFF)
(SETQ VAL (DISPLAYDOWN FORM))
(\KEYBOARDON)
(RETURN VAL))))
)
(* Compile locked fns together for locality)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NIL FLIPCURSORBAR \KEYHANDLER \KEYHANDLER1 \TRACKCURSOR \PERIODIC.INTERRUPTFRAME
\TIMER.INTERRUPTFRAME \DOBUFFEREDTRANSITIONS \DOTRANSITIONS \DECODETRANSITION \EVENTKEYS
\HARDCURSORUP \HARDCURSORPOSITION \HARDCURSORDOWN \SOFTCURSORUP \SOFTCURSORUPCURRENT
\SOFTCURSORPOSITION \SOFTCURSORDOWN)
]
(DECLARE: DONTCOPY
(ADDTOVAR INEWCOMS
(ALLOCAL (ADDVARS (LOCKEDFNS FLIPCURSORBAR \SETIOPOINTERS \KEYHANDLER \KEYHANDLER1
\CONTEXTAPPLY \LOCKPAGES \DECODETRANSITION \SMASHLINK \INCUSECOUNT
LLSH \MAKEFREEBLOCK \DECUSECOUNT \MAKENUMBER \ADDBASE
\PERIODIC.INTERRUPTFRAME \DOBUFFEREDTRANSITIONS
\TIMER.INTERRUPTFRAME \TRACKCURSOR \HARDCURSORUP
\HARDCURSORPOSITION \HARDCURSORDOWN \SOFTCURSORUP
\SOFTCURSORUPCURRENT \SOFTCURSORPOSITION \SOFTCURSORDOWN
\SOFTCURSORPILOTBITBLT)
(LOCKEDVARS \InterfacePage \CURSORHOTSPOTX \CURSORHOTSPOTY \CURRENTCURSOR
\SOFTCURSORWIDTH \SOFTCURSORHEIGHT \SOFTCURSORP \SOFTCURSORUPP
\SOFTCURSORUPBM \SOFTCURSORDOWNBM \SOFTCURSORBBT1 \SOFTCURSORBBT2
\SOFTCURSORBBT3 \SOFTCURSORBBT4 \SOFTCURSORBBT5 \SOFTCURSORBBT6
\CURSORDESTINATION \CURSORDESTHEIGHT \CURSORDESTWIDTH
\CURSORDESTRASTERWIDTH \CURSORDESTLINE \CURSORDESTLINEBASE
\PENDINGINTERRUPT \PERIODIC.INTERRUPT \PERIODIC.INTERRUPT.FREQUENCY
\LASTUSERACTION \MOUSECHORDTICKS \KEYBOARDEVENTQUEUE \KEYBUFFERING
SCREENWIDTH SCREENHEIGHT \TIMER.INTERRUPT.PENDING \EM.MOUSEX
\EM.MOUSEY \EM.CURSORX \EM.CURSORY \EM.UTILIN \EM.REALUTILIN
\EM.KBDAD0 \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3 \EM.DISPINTERRUPT
\EM.CURSORBITMAP \EM.KBDAD4 \EM.KBDAD5 \MISCSTATS \RCLKSECOND))))
(ADDTOVAR RDCOMS (FNS \SETIOPOINTERS))
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML WITHOUT-INTERRUPTS)
(ADDTOVAR LAMA CURSORPROP METASHIFT MOUSECHORDWAIT)
)
(PUTPROPS LLKEY COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (12664 18323 (BKSYSCHARCODE 12674 . 13003) (\CLEARSYSBUF 13005 . 13517) (\GETKEY 13519
. 14377) (\NSYSBUFCHARS 14379 . 14982) (\SAVESYSBUF 14984 . 16227) (\SYSBUFP 16229 . 16552) (
\GETSYSBUF 16554 . 16739) (\PUTSYSBUF 16741 . 17518) (\PEEKSYSBUF 17520 . 18321)) (19791 49200 (
\KEYBOARDINIT 19801 . 21231) (\KEYBOARDEVENTFN 21233 . 23115) (\ALLOCLOCKED 23117 . 23607) (
\SETIOPOINTERS 23609 . 28616) (\KEYBOARDOFF 28618 . 28858) (\KEYBOARDON 28860 . 29093) (\KEYHANDLER
29095 . 29227) (\KEYHANDLER1 29229 . 35000) (\RESETKEYBOARD 35002 . 36455) (\DOMOUSECHORDING 36457 .
39874) (\DOTRANSITIONS 39876 . 40564) (\DECODETRANSITION 40566 . 45488) (MOUSECHORDWAIT 45490 . 46012)
(\TRACKCURSOR 46014 . 49198)) (72026 80861 (KEYACTION 72036 . 72573) (KEYACTIONTABLE 72575 . 72943) (
\KEYACTION1 72945 . 77453) (KEYDOWNP 77455 . 77728) (\KEYNAMETONUMBER 77730 . 78316) (
MODIFY.KEYACTIONS 78318 . 78732) (METASHIFT 78734 . 79575) (SHIFTDOWNP 79577 . 80859)) (80920 81221 (
SETUP.OFFICE.KEYBOARD 80930 . 81219)) (85126 86082 (\INIT.KEYBOARD.STREAM 85136 . 86080)) (86336 93361
(\DOBUFFEREDTRANSITIONS 86346 . 92563) (\TIMER.INTERRUPTFRAME 92565 . 93134) (
\PERIODIC.INTERRUPTFRAME 93136 . 93359)) (93610 96876 (\HARDCURSORUP 93620 . 94853) (
\HARDCURSORPOSITION 94855 . 96720) (\HARDCURSORDOWN 96722 . 96874)) (96877 116307 (CURSOR.INIT 96887
. 99704) (\CURSORDESTINATION 99706 . 101331) (\SOFTCURSORUP 101333 . 105459) (\SOFTCURSORUPCURRENT
105461 . 111197) (\SOFTCURSORPOSITION 111199 . 111840) (\SOFTCURSORDOWN 111842 . 112437) (CURSORPROP
112439 . 112769) (GETCURSORPROP 112771 . 112962) (PUTCURSORPROP 112964 . 113858) (\CURSORBITSPERPIXEL
113860 . 115769) (\CURSORIMAGEPROPNAME 115771 . 116039) (\CURSORMASKPROPNAME 116041 . 116305)) (116308
129523 (CURSORCREATE 116318 . 117498) (CURSOR 117500 . 118626) (\CURSORUP 118628 . 119818) (
\CURSORPOSITION 119820 . 121947) (\CURSORDOWN 121949 . 122169) (ADJUSTCURSORPOSITION 122171 . 122678)
(CURSORPOSITION 122680 . 124311) (CURSORSCREEN 124313 . 125072) (CURSOREXIT 125074 . 126681) (
FLIPCURSOR 126683 . 127211) (FLIPCURSORBAR 127213 . 127677) (LASTMOUSEX 127679 . 128005) (LASTMOUSEY
128007 . 128333) (CREATEPOSITION 128335 . 128542) (POSITIONP 128544 . 128905) (CURSORHOTSPOT 128907 .
129521)) (130757 132190 (GETMOUSESTATE 130767 . 131331) (\EVENTKEYS 131333 . 132188)) (137061 137859 (
MACHINETYPE 137071 . 137466) (SETMAINTPANEL 137468 . 137857)) (137885 138804 (BEEPON 137895 . 138404)
(BEEPOFF 138406 . 138802)) (139236 139497 (WITHOUT-INTERRUPTS 139246 . 139495)))))
STOP