(FILECREATED "17-Apr-84 05:51:33" {PHYLUM}<LISPCORE>SOURCES>LLKEY.;4 88073
changes to: (FNS \CAUSE.PERIODIC.INTERRUPT)
previous date: " 6-Apr-84 18:03:52" {PHYLUM}<LISPCORE>SOURCES>LLKEY.;3)
(* Copyright (c) 1982, 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT LLKEYCOMS)
(RPAQQ LLKEYCOMS [(COMS (* Access to keyboard)
(FNS BKSYSCHARCODE \CLEARSYSBUF \GETKEY \INTCHAR \NSYSBUFCHARS \SAVESYSBUF
\SYSBUFP \GETSYSBUF \PUTSYSBUF \PEEKSYSBUF)
(GLOBALRESOURCES (\KEYBOARDWAITBOX (CREATECELL \FIXP)))
(DECLARE: DONTCOPY (CONSTANTS (\SYSBUFSIZE 200))
(MACROS \GETREALSYSBUF)))
[DECLARE: DOCOPY DONTEVAL@LOAD (P (MOVD? (QUOTE \BACKGROUNDSUBR)
(QUOTE \TTYBACKGROUND))
(MOVD? (QUOTE \BACKGROUNDSUBR)
(QUOTE \BACKGROUND)))
(COMS (* Here because it must be done in init before PROC loaded)
(P (MOVD? (QUOTE NILL)
(QUOTE CARET]
(COMS (* Key handler)
(FNS \KEYBOARDINIT \ALLOCLOCKED \SETIOPOINTERS \KEYBOARDOFF \KEYBOARDON \KEYHANDLER
\KEYHANDLER1 \RESETKEYBOARD \RESETKEYBOARD1 \DOMOUSETRANSITIONS \DOTRANSITIONS
\DECODETRANSITION MOUSECHORDWAIT)
(INITVARS (\MOUSECHORDTICKS 1750))
(DECLARE: DONTEVAL@LOAD DOCOPY (P (\KEYBOARDINIT)))
(DECLARE: DONTCOPY (MACROS .NOTELASTUSERACTION)
(E (RESETSAVE (RADIX 8)))
(CONSTANTS CURSORYMAX SCREENHEIGHT ALLUP \CTRLMASK \METABIT)
(CONSTANTS * DLMOUSEBITS)
(CONSTANTS * DLMOUSESTATES)
(CONSTANTS * TRANSITIONFLAGS)
(MACROS \TRANSINDEX)
(EXPORT (RECORDS INTERRUPTSTATE ARMEDINTERRUPTS))
(RECORDS TRANSITION SHIFTSTATE RING)
(CONSTANTS NRINGINDEXWORDS)
(CONSTANTS * SHIFTBITS)
[CONSTANTS (\SYSBUFFER.FIRST (UNFOLD NRINGINDEXWORDS BYTESPERWORD))
(\SYSBUFFER.LAST (SUB1 (IPLUS \SYSBUFSIZE (UNFOLD NRINGINDEXWORDS
BYTESPERWORD]
(CONSTANTS BYTESPERTRANSITION NKEYS))
(DECLARE: EVAL@COMPILE (VARS \KEYNAMES))
(VARS \ORIGKEYACTIONS \MODIFIED.KEYACTIONS)
(E (RADIX 10))
(GLOBALVARS \SYSBUFFER \LONGSYSBUF \TRANSITIONFLAGS \TRANSITIONCODES
\TRANSITIONSHIFTCODES \ARMEDINTERRUPTS \INTERRUPTSTATE \SHIFTSTATE
\MODIFIED.KEYACTIONS \EVENTSTATUS \EVENTQUEUE \RCLKSECOND \LASTUSERACTION
\MOUSECHORDTICKS))
(COMS (* Key interpretation)
(FNS KEYACTION \KEYACTION1 KEYDOWNP KEYDOWNP1 \KEYNAMETONUMBER MODIFY.KEYACTIONS
METASHIFT)
(DECLARE: EVAL@COMPILE DONTCOPY (FNS \KEYNAMETONUMBER))
(EXPORT (MACROS KEYDOWNP KEYDOWNP1)))
[COMS (FNS \SHOWCOLORCURSOR)
(INITVARS (\COLORCURSORBM)
(\COLORCURSORDOWN)
(\ColorCursorBBT)
(\COLORCURSOR))
(EXPORT (MACROS COLORNUMBERBITSPERPIXEL \BITADDRESSOFPIXEL .TAKE.DOWN.COLOR.CURSOR)
(CONSTANTS (COLORSCREENWIDTH 640)
(COLORSCREENHEIGHT 480]
(COMS (* A raw keyboard device/stream)
(FNS \INIT.KEYBOARD.STREAM \KEYBOARD.GETEOFPTR \KEYBOARD.BACKFILEPTR)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (\INIT.KEYBOARD.STREAM)))
(EXPORT (GLOBALVARS \KEYBOARD.DEVICE \KEYBOARD.STREAM)))
(COMS (* Hook for a periodic interrupt)
(FNS \PERIODIC.INTERRUPTFRAME \CAUSE.PERIODIC.INTERRUPT)
(VARS (\PERIODIC.INTERRUPT))
(INITVARS (\PERIODIC.INTERRUPT.FREQUENCY 60)))
(LOCALVARS . T)
[COMS (* cursor and mouse related functions.)
(FNS ADJUSTCURSORPOSITION CREATEPOSITION CURSOR CURSORCREATE CURSORHOTSPOT
CURSORPOSITION \SETCURSORPOSITION FLIPCURSOR LASTMOUSEX LASTMOUSEY POSITIONP
SETCURSOR)
(FNS GETMOUSESTATE \EVENTKEYS)
[EXPORT (CONSTANTS (CURSORHEIGHT 16)
(CURSORWIDTH 16))
(DECLARE: DONTCOPY (MACROS FLIPCURSORBAR))
(GLOBALVARS BUTTONCHARCODE)
(DECLARE: EVAL@COMPILE (ADDVARS (GLOBALVARS LASTMOUSEX LASTMOUSEY
LASTMOUSEBUTTONS LASTMOUSETIME
LASTKEYBOARD]
(INITVARS (\MOUSEHOTSPOTX 0)
(\MOUSEHOTSPOTY 15))
(GLOBALVARS \MOUSEHOTSPOTX \MOUSEHOTSPOTY \MOUSETIMEBOX \COLORCURSOR)
(DECLARE: DONTCOPY (EXPORT (MACROS \SETMOUSEXY))
(MACROS \XMOUSECOORD \YMOUSECOORD))
[DECLARE: DONTEVAL@LOAD DOCOPY (VARS (\SFPosition (CREATEPOSITION]
(DECLARE: DOEVAL@COMPILE (VARS (SCREENHEIGHT 808]
[COMS (* Queued mouse)
(FNS BKMOUSEBUF CLEARMOUSEBUF ENABLEMOUSE GETMOUSEEVENT MOUSEBUF \PUTEVENTQUEUE
\ResetMouseQueue)
(DECLARE: DONTEVAL@LOAD DOCOPY (VARS (\MouseEnabled)
(\MouseQueueAddrLo 51712)
(\MouseQueueOverhead 4)
(\SingleMouseEvent NIL)
(\MouseEventQueue)
(\ClearedMouseEvents)
(BUTTONCHARCODE)))
(GLOBALVARS \MouseQueueAddrLo \MouseEventQueue \MouseQueueOverhead \SingleMouseEvent
\MouseEnabled \DISPLAYREGION \ClearedMouseEvents)
(DECLARE: DONTCOPY (RECORDS MOUSEQUEUE MOUSEPTR)
(CONSTANTS \MouseEventLength)
(RECORDS EVENTPTR EVENTSTATUS)
(CONSTANTS NO.EV CHAR.EV YES.EV)
(CONSTANTS EVENTLENGTH (\EVENTQUEUE.FIRST NRINGINDEXWORDS)
(\EVENTQUEUE.LAST
(IPLUS NRINGINDEXWORDS
(ITIMES EVENTLENGTH
(SUB1 (IQUOTIENT (IDIFFERENCE
(UNFOLD 2 WORDSPERPAGE)
(IPLUS 2 1 (FOLDHI
\SYSBUFFER.LAST
BYTESPERWORD)
1 NRINGINDEXWORDS))
EVENTLENGTH]
(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
\COLORCURSORBM \COLORCURSOR \COLORCURSORDOWN \ColorCursorBBT
\COLORCURSORWIDTH \COLORSCREENCURSORLINEBASE \COLORSCREENCURSORLINE
\COLORCURSORBASE \COLORSCREENWIDTHINBITS \COLORSCREENRASTERWIDTH
\COLORCURSORRASTERWIDTH))
(FNS WITHOUT-INTERRUPTS)
(COMS (* Compile locked fns together for locality)
(BLOCKS (NIL \PUTSYSBUF \KEYHANDLER \KEYHANDLER1 \RESETKEYBOARD1 \DOTRANSITIONS
\DOMOUSETRANSITIONS \DECODETRANSITION KEYDOWNP1 \PERIODIC.INTERRUPTFRAME
\CAUSE.PERIODIC.INTERRUPT \EVENTKEYS \PUTEVENTQUEUE)))
[DECLARE: DONTCOPY
(ADDVARS [INEWCOMS (ALLOCAL (ADDVARS (LOCKEDFNS \KEYHANDLER \KEYHANDLER1
\RESETKEYBOARD1 \DOTRANSITIONS
\DOMOUSETRANSITIONS \CONTEXTAPPLY
\LOCKPAGES \DECODETRANSITION
\SMASHLINK \PUTEVENTQUEUE
\INCUSECOUNT \PUTSYSBUF CLOCK0
\EVENTKEYS KEYDOWNP1 LRSH LLSH
\MAKEFREEBLOCK \DECUSECOUNT
\MAKENUMBER \ADDBASE
\PERIODIC.INTERRUPTFRAME
\CAUSE.PERIODIC.INTERRUPT)
(LOCKEDVARS \InterfacePage \TRANSITIONFLAGS
\SHIFTSTATE \TRANSITIONSHIFTCODES
\TRANSITIONCODES \EVENTSTATUS
\ARMEDINTERRUPTS \EVENTQUEUE
\MOUSEHOTSPOTX \MOUSEHOTSPOTY
\MOUSETIMEBOX \SYSBUFFER
\PENDINGINTERRUPT \COLORCURSORBM
\COLORCURSORDOWN
\COLORDISPLAYBITSPERPIXEL
\ColorCursorBBT \COLORCURSORWIDTH
\COLORSCREENCURSORLINE
\COLORSCREENCURSORLINEBASE
\COLORCURSORBASE
\COLORSCREENWIDTHINBITS
\COLORSCREENRASTERWIDTH
\COLORCURSORRASTERWIDTH
\PERIODIC.INTERRUPT
\PERIODIC.INTERRUPT.FREQUENCY
\LASTUSERACTION \MOUSECHORDTICKS)
(LOCKEDVARS \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.DISPLAYHEAD]
(RDCOMS (FNS \SETIOPOINTERS]
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML
WITHOUT-INTERRUPTS)
(LAMA 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) (* bvm: "24-JUL-83 17:23")
(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 (* bvm: "20-JUL-83 12:16")
(DECLARE (GLOBALVARS \KEYBOARDWAIT1 \KEYBOARDWAIT2))
(COND
[(AND (THIS.PROCESS)
(fetch PROCTYPEAHEAD of (THIS.PROCESS)))
(pop (fetch PROCTYPEAHEAD of (THIS.PROCESS]
(T (PROCESS.PREPARE.FOR.INPUT NIL
"Can't access the keyboard in this process:
Process is not the tty process, and it owns no window")
(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])
(\INTCHAR
[LAMBDA (CODE FLAG) (* lmm " 3-NOV-82 12:48")
(* sets the bit which says that character CODE is armed
as an interrupt)
(PROG1 (fetch ARMED of CODE)
(replace ARMED of CODE with FLAG])
(\NSYSBUFCHARS
[LAMBDA NIL (* rmk: "16-SEP-83 23:59")
(* 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
((ZEROP R)
0)
((IGREATERP W R)
(IDIFFERENCE W R))
(T (IDIFFERENCE W (IDIFFERENCE R \SYSBUFSIZE])
(\SAVESYSBUF
[LAMBDA NIL (* rmk: "17-SEP-83 00:53")
(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 (ZEROP NC))
(SUBSTRING BUF 1 NC])
(\SYSBUFP
[LAMBDA NIL (* bvm: "20-JUL-83 12:03")
(OR [AND (TTY.PROCESSP)
(OR \LONGSYSBUF (NOT (ZEROP (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) (* lmm " 9-JUL-83 00:45")
(PROG ((R (fetch (RING READ) of \SYSBUFFER))
(W (fetch (RING WRITE) of \SYSBUFFER)))
(RETURN (COND
((EQ R W) (* Full)
NIL)
(T (\PUTBASEBYTE \SYSBUFFER W CHAR)
(AND (ZEROP 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) (* rrb "30-Dec-83 11:56")
(PROG (R)
WAIT(until (\SYSBUFP) do (BLOCK))
(RETURN (if (TTY.PROCESSP)
then (if \LONGSYSBUF
then (CAR \LONGSYSBUF)
elseif [NOT (ZEROP (SETQ R (fetch (RING READ) of \SYSBUFFER]
then (* Here's the vanilla case)
(\GETBASEBYTE \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])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(PUTDEF (QUOTE \KEYBOARDWAITBOX)
(QUOTE GLOBALRESOURCES)
(QUOTE (CREATECELL \FIXP)))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \KEYBOARDWAITBOX)
)
(RPAQQ \KEYBOARDWAITBOX NIL)
(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 (ZEROP R))
(PROG1 (\GETBASEBYTE \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
(MOVD? (QUOTE \BACKGROUNDSUBR)
(QUOTE \TTYBACKGROUND))
(MOVD? (QUOTE \BACKGROUNDSUBR)
(QUOTE \BACKGROUND))
(* Here because it must be done in init before PROC loaded)
(MOVD? (QUOTE NILL)
(QUOTE CARET))
)
(* Key handler)
(DEFINEQ
(\KEYBOARDINIT
[LAMBDA NIL (* lmm "10-JUL-83 12:19")
(DECLARE (GLOBALVARS \KEYBOARDWAIT1 \KEYBOARDWAIT2 \SAVEDSYSBUFFER))
(* Sets up keyboard decoding tables.)
[CHECK (ZEROP (LOGAND \LispKeyMask (EMGETBASE DISPINTERRUPT.EM]
[SETQ \TRANSITIONFLAGS (\ALLOCLOCKED (CONSTANT (FOLDHI (IPLUS NKEYS NKEYS)
BYTESPERCELL]
[SETQ \TRANSITIONCODES (\ALLOCLOCKED (CONSTANT (FOLDHI (PLUS NKEYS NKEYS)
BYTESPERCELL]
[SETQ \TRANSITIONSHIFTCODES (\ALLOCLOCKED (CONSTANT (FOLDHI (PLUS NKEYS NKEYS)
BYTESPERCELL]
(SETQ \ARMEDINTERRUPTS (\ALLOCLOCKED (FOLDHI (ADD1 \MAXCHAR)
BITSPERCELL)))
(for X in \ORIGKEYACTIONS do (KEYACTION (CAR X)
(CDR X)))
(SETQ \SHIFTSTATE (\ALLOCLOCKED (UNFOLD CELLSPERPAGE 2)))
(* 2 words for shiftstate, 1 for interruptchar, 2 for sysbuffer pointers -1 : pointers, then the sysbuffer itself.
The rest of this page and the next are given to the mouse queue--1 status word, the 2 ring overhead pointers, and
however many mouseevents will fit.)
(* yekko -- pointers to middle of array blocks non-legit
since screw up possible copying GC)
(SETQ \INTERRUPTSTATE (ADDBASE \SHIFTSTATE 2))
(SETQ \SYSBUFFER (ADDBASE \INTERRUPTSTATE 1))
(replace (RING READ) of \SYSBUFFER with 0)
(replace (RING WRITE) of \SYSBUFFER with \SYSBUFFER.FIRST)
(* Now for the mouse queue)
(SETQ \EVENTSTATUS (ADDBASE \SYSBUFFER (FOLDHI \SYSBUFFER.LAST BYTESPERWORD)))
(SETQ \EVENTQUEUE (ADDBASE \EVENTSTATUS 1))
(replace (RING READ) of \EVENTQUEUE with 0)
(replace (RING WRITE) of \EVENTQUEUE with \EVENTQUEUE.FIRST)
(SETQ \KEYBOARDWAIT1 (CREATECELL \FIXP)) (* Miscellaneous)
(SETQ \KEYBOARDWAIT2 (CREATECELL \FIXP))
(SETQ \SAVEDSYSBUFFER (ALLOCSTRING \SYSBUFSIZE))
(SETQ \MOUSETIMEBOX (CREATECELL \FIXP))
(SETQ \LASTUSERACTION (LOCF (fetch LASTUSERACTION of \MISCSTATS)))
(\KEYBOARDON])
(\ALLOCLOCKED
[LAMBDA (NCELLS) (* lmm " 1-AUG-82 06:51")
(* allocate a block of NCELLS cells and lock it)
(PROG ((BLOCK (\ALLOCBLOCK NCELLS)))
(\LOCKCELL BLOCK (FOLDHI (IPLUS (fetch (POINTER WORDINPAGE) of BLOCK)
(UNFOLD NCELLS WORDSPERCELL))
WORDSPERPAGE))
(RETURN BLOCK])
(\SETIOPOINTERS
[LAMBDA NIL (* bvm: " 6-Apr-84 17:57")
(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))
(PROGN (SETTOPVAL (QUOTE \EM.REALUTILIN)
(EMADDRESS UTILIN.EM))
(SETTOPVAL (QUOTE \EM.UTILIN)
(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)
NIL)
(SETTOPVAL (QUOTE \EM.KBDAD5)
NIL)
(SETTOPVAL (QUOTE \EM.DISPINTERRUPT)
(EMADDRESS DISPINTERRUPT.EM))
(SETTOPVAL (QUOTE \EM.CURSORBITMAP)
(EMADDRESS CURSORBITMAP.EM))
[SETTOPVAL (QUOTE \MIDDLEKEY)
(CONSTANT (\KEYNAMETONUMBER (QUOTE YELLOW]
(SETTOPVAL (QUOTE \EM.DISPLAYHEAD)
(EMADDRESS DCB.EM)))
(\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.UTILIN)
(LOCF (fetch (IFPAGE FAKEMOUSEBITS) of \InterfacePage]
(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 \MIDDLEKEY)
(CONSTANT (\KEYNAMETONUMBER (QUOTE CENTER]
(SETTOPVAL (QUOTE \EM.DISPLAYHEAD)
NIL))
(RAID])
(\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: " 6-Apr-84 17:32")
(PROG ((OLD0 ALLUP)
(OLD1 ALLUP)
(OLD2 ALLUP)
(OLD3 ALLUP)
(OLD4 ALLUP)
(OLD5 ALLUP)
(OLDU ALLUP)
(LOOPCNT 10)
(PERIODCNT 60)
(MOUSESTATE \DLMOUSE.UP)
(MOUSETIMER (LOCF (fetch DLMOUSETIMER of \MISCSTATS)))
(MOUSETEMP (LOCF (fetch DLMOUSETEMP of \MISCSTATS)))
SCRWIDTH CURSORX CURSORY YHOT)
(DECLARE (SPECVARS SCRWIDTH MOUSESTATE)
(GLOBALVARS \PENDINGINTERRUPT \PERIODIC.INTERRUPT \PERIODIC.INTERRUPT.FREQUENCY))
(* SCRWIDTH is set remotely by \RESETKEYBOARD1)
(\RESETKEYBOARD1)
LP (\CONTEXTSWITCH \KbdFXP)
(COND
[(OR (NEQ (\GETBASE \EM.MOUSEX 0)
CURSORX)
(NEQ (\GETBASE \EM.MOUSEY 0)
CURSORY))
(.NOTELASTUSERACTION)
(COND
(\COLORCURSORBM (* cursor is on the color screen.)
[COND
((IGREATERP (SETQ CURSORX (\GETBASE \EM.MOUSEX 0))
COLORSCREENWIDTH)
(* 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)
(SETQ CURSORX 0))
(T (SETQ CURSORX COLORSCREENWIDTH]
[COND
((IGREATERP (SETQ CURSORY (\GETBASE \EM.MOUSEY 0))
(CONSTANT (SUB1 COLORSCREENHEIGHT)))
(* 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)
(SETQ CURSORY 0))
(T (SETQ CURSORY (CONSTANT (SUB1 COLORSCREENHEIGHT]
(COND
((NULL \COLORCURSORDOWN) (* unless the cursor is down, take it down from it
current position.)
(.TAKE.DOWN.COLOR.CURSOR)
(* put the cursor image up in its new position.)
(\SHOWCOLORCURSOR CURSORX CURSORY)))
(* update the cursor position.)
(\PUTBASE \EM.MOUSEX 0 CURSORX)
(\PUTBASE \EM.CURSORX 0 CURSORX)
(\PUTBASE \EM.MOUSEY 0 CURSORY)
(\PUTBASE \EM.CURSORY 0 CURSORY))
(T (* move cursor if the mouse position has changed.)
(SETQ CURSORY (\GETBASE \EM.MOUSEY 0))
(SETQ CURSORX (\GETBASE \EM.MOUSEX 0))
(COND
([OR [COND
((IGEQ CURSORX (IDIFFERENCE SCRWIDTH \MOUSEHOTSPOTX))
(* 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))
\MOUSEHOTSPOTX)
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 \MOUSEHOTSPOTX)
BITSPERWORD]
(T (SETQ CURSORX (SUB1 (IDIFFERENCE SCRWIDTH \MOUSEHOTSPOTX]
(COND
((IGEQ CURSORY (CONSTANT (IDIFFERENCE SCREENHEIGHT CURSORHEIGHT)))
(* Large cursor values are either out of bounds to the
bottom or are negative values
(16-bit bcpl signed numbers))
(SETQ YHOT (IDIFFERENCE \MOUSEHOTSPOTY CURSORHEIGHT))
(* Negative distance of Y hotspot from top of cursor)
(COND
[(IGREATERP CURSORY 32767) (* Cursor value is negative)
(COND
((ILESSP (IDIFFERENCE (SUB1 (IDIFFERENCE CURSORY 65535))
YHOT)
0) (* Cursor pos + hotspot is still off to the top, so clip
to effective zero)
(SETQ CURSORY (COND
((EQ \MACHINETYPE \DANDELION)
(* Temporary workaround)
0)
(T (UNSIGNED YHOT BITSPERWORD]
((IGEQ CURSORY (SETQ YHOT (IPLUS SCREENHEIGHT YHOT)))
(SETQ CURSORY (SUB1 YHOT]
(* If need to clip mouse, do so here. note simple optimization only checks for one dimension per click, but that's
ok. \SETMOUSEXY MACRO takes dlion complexities into account.)
(\SETMOUSEXY CURSORX CURSORY))) (* Now track mouse by copying mouse position into cursor
position)
(\PUTBASE \EM.CURSORX 0 CURSORX)
(\PUTBASE \EM.CURSORY 0 CURSORY]
(T (* CURSOR HASN'T MOVED, DO NOTHING)))
(* Now see if CHARACTER MAPPINGS changed)
[OR (EQ OLD0 (\GETBASE \EM.KBDAD0 0))
(\DOTRANSITIONS 0 OLD0 (SETQ OLD0 (\GETBASE \EM.KBDAD0 0]
(* Swap state before call, cause \DOTRANSITIONS
guarantees to complete processing this word.)
[OR (EQ OLD1 (\GETBASE \EM.KBDAD1 0))
(\DOTRANSITIONS 16 OLD1 (SETQ OLD1 (\GETBASE \EM.KBDAD1 0]
[OR (EQ OLD2 (\GETBASE \EM.KBDAD2 0))
(PROGN (COND
((ZEROP (LOGAND OLD2 2114)) (* Cntrl-Shift-DEL emergency interrupt.
Cause a context switch to TeleRaid to handle this)
(swap (fetch (IFPAGE TELERAIDFXP) of \InterfacePage)
(fetch (IFPAGE KbdFXP) of \InterfacePage))
(SETQ OLD2 (\GETBASE \EM.KBDAD2 0))
(GO LP)))
(\DOTRANSITIONS 32 OLD2 (SETQ OLD2 (\GETBASE \EM.KBDAD2 0]
[OR (EQ OLD3 (\GETBASE \EM.KBDAD3 0))
(\DOTRANSITIONS 48 OLD3 (SETQ OLD3 (\GETBASE \EM.KBDAD3 0]
[COND
(\EM.KBDAD4 [OR (EQ (\GETBASE \EM.KBDAD4 0)
OLD4)
(\DOTRANSITIONS 80 OLD4 (SETQ OLD4 (\GETBASE \EM.KBDAD4 0]
(OR (EQ OLD5 (\GETBASE \EM.KBDAD5 0))
(\DOTRANSITIONS 96 OLD5 (SETQ OLD5 (\GETBASE \EM.KBDAD5 0]
[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)))
(COND
[(NEQ \MACHINETYPE \DANDELION)
(\DOTRANSITIONS 64 OLDU (SETQ OLDU (\GETBASE \EM.REALUTILIN 0]
(T (SETQ MOUSESTATE (\DOMOUSETRANSITIONS (SETQ OLDU (\GETBASE \EM.REALUTILIN 0))
MOUSESTATE]
[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
(\PENDINGINTERRUPT (AND (\CAUSEINTERRUPT \KbdFXP)
(SETQ \PENDINGINTERRUPT]
[COND
(\PERIODIC.INTERRUPT (COND
((ILEQ (SETQ PERIODCNT (SUB1 PERIODCNT))
0)
(SETQ PERIODCNT (COND
((\CAUSE.PERIODIC.INTERRUPT \KbdFXP)
\PERIODIC.INTERRUPT.FREQUENCY)
(T (* Failed, try again soon)
1]
(GO LP])
(\RESETKEYBOARD
[LAMBDA NIL (* lmm "30-MAR-83 20:40")
(\SETIOPOINTERS) (* Called with lisp keyboard disabled whenever Lisp is resumed from bcpl logout
or copysys.)
(* call \RESETKEYBOARD1 with ALINK pointing at the Keyboard handler's frame)
(\CONTEXTAPPLY \KbdFXP (FUNCTION \RESETKEYBOARD1))
(* Finally, turn off the bcpl keyboard and start the Lisp keyboard interrupts)
(\KEYBOARDON])
(\RESETKEYBOARD1
[LAMBDA NIL (* bvm: " 6-Apr-84 11:40")
(* Called either from underneath \KEYHANDLER or with keyboard strobe disabled. Access link of this function is the
\KEYHANDLER prog. This cannot be a macro.)
(DECLARE (USEDFREE SCRWIDTH MOUSESTATE))
(SETQ SCRWIDTH (UNFOLD (fetch (IFPAGE ScreenWidth) of \InterfacePage)
BITSPERWORD))
(SETQ MOUSESTATE \DLMOUSE.UP)
(replace (SHIFTSTATE SHIFTORLOCK) of \SHIFTSTATE with NIL)
(replace (SHIFTSTATE LOCK) of \SHIFTSTATE with (KEYDOWNP (QUOTE LOCK)))
(replace (SHIFTSTATE CTRL) of \SHIFTSTATE with NIL])
(\DOMOUSETRANSITIONS
[LAMBDA (REALUTILIN STATE) (* bvm: " 6-Apr-84 14:32")
(* 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)
(PROG (LRSTATE)
[COND
([OR (NULL \MOUSECHORDTICKS)
(ZEROP (SETQ LRSTATE (LOGXOR (LOGAND REALUTILIN \MOUSE.ALLBITS)
\MOUSE.ALLBITS]
(* 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))
(T (* 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)]
(\DOTRANSITIONS 64 (\GETBASE \EM.UTILIN 0)
REALUTILIN)
(\PUTBASE \EM.UTILIN 0 REALUTILIN)
(RETURN STATE])
(\DOTRANSITIONS
[LAMBDA (KEYBASE OLD NEW) (* rmk: "29-MAY-81 14:07")
(* 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 (ZEROP (LOGAND BITMASK (LOGXOR OLD NEW)))
(\DECODETRANSITION (IPLUS I KEYBASE)
(ZEROP (LOGAND NEW BITMASK]
(SETQ BITMASK (LRSH BITMASK 1])
(\DECODETRANSITION
[LAMBDA (KEYNUMBER DOWNFLG) (* bvm: " 2-AUG-83 18:22")
(* 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.)
(DECLARE (USEDFREE PENDINGINTERRUPT))
(.NOTELASTUSERACTION)
(PROG (ASCIICODE (TI (\TRANSINDEX KEYNUMBER DOWNFLG)))
(SELECTC (fetch (TRANSITION FLAGS) of TI)
(IGNORE.TF (RETURN))
[LOCKSHIFT.TF (SETQ ASCIICODE (COND
((fetch (SHIFTSTATE SHIFTORLOCK) of \SHIFTSTATE)
(fetch (TRANSITION SHIFTCODE) of TI))
(T (fetch (TRANSITION CODE) of TI]
[NOLOCKSHIFT.TF (SETQ ASCIICODE (COND
((fetch (SHIFTSTATE SHIFT) of \SHIFTSTATE)
(fetch (TRANSITION SHIFTCODE) of TI))
(T (fetch (TRANSITION CODE) of TI]
(EVENT.TF (SELECTC (fetch EVENTSENABLED of \EVENTSTATUS)
(NO.EV)
(CHAR.EV (\PUTEVENTQUEUE (fetch EVENTCHARCODE of \EVENTSTATUS)))
(YES.EV (\PUTEVENTQUEUE))
(SHOULDNT))
(RETURN))
(1SHIFTUP.TF (replace (SHIFTSTATE 1SHIFT) of \SHIFTSTATE with NIL)
(RETURN))
(1SHIFTDOWN.TF (replace (SHIFTSTATE 1SHIFT) of \SHIFTSTATE with T)
(RETURN))
(2SHIFTUP.TF (replace (SHIFTSTATE 2SHIFT) of \SHIFTSTATE with NIL)
(RETURN))
(2SHIFTDOWN.TF (replace (SHIFTSTATE 2SHIFT) of \SHIFTSTATE with T)
(RETURN))
(LOCKUP.TF (replace (SHIFTSTATE LOCK) of \SHIFTSTATE with NIL)
(RETURN))
(LOCKDOWN.TF (replace (SHIFTSTATE LOCK) of \SHIFTSTATE with T)
(RETURN))
(CTRLUP.TF (replace (SHIFTSTATE CTRL) of \SHIFTSTATE with NIL)
(RETURN))
(CTRLDOWN.TF (replace (SHIFTSTATE CTRL) of \SHIFTSTATE with T)
(RETURN))
(METAUP.TF (replace (SHIFTSTATE META) of \SHIFTSTATE with NIL)
(RETURN))
(METADOWN.TF (replace (SHIFTSTATE META) of \SHIFTSTATE with T)
(RETURN))
(SHOULDNT))
(AND (fetch (SHIFTSTATE CTRL) of \SHIFTSTATE)
(SETQ ASCIICODE (LOGAND ASCIICODE \CTRLMASK)))
(AND (fetch (SHIFTSTATE META) of \SHIFTSTATE)
(SETQ ASCIICODE (LOGOR ASCIICODE \METABIT)))
(COND
((fetch ARMED of ASCIICODE)
(SETQ \PENDINGINTERRUPT T)
(replace WAITINGINTERRUPT of \INTERRUPTSTATE with T)
(replace INTCHARCODE of \INTERRUPTSTATE with ASCIICODE))
(T (\PUTSYSBUF ASCIICODE])
(MOUSECHORDWAIT
[LAMBDA MSECS (* bvm: " 6-Apr-84 15:14")
(PROG1 (AND \MOUSECHORDTICKS (IQUOTIENT \MOUSECHORDTICKS \DLION.RCLKMILLISECOND))
(COND
((IGREATERP MSECS 0)
(SETQ \MOUSECHORDTICKS (AND (ARG MSECS 1)
(IMIN MAX.SMALLP (ITIMES (ARG MSECS 1)
\DLION.RCLKMILLISECOND])
)
(RPAQ? \MOUSECHORDTICKS 1750)
(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 CURSORYMAX 1430Q)
(RPAQQ SCREENHEIGHT 1450Q)
(RPAQQ ALLUP 177777Q)
(RPAQQ \CTRLMASK 237Q)
(RPAQQ \METABIT 200Q)
(CONSTANTS CURSORYMAX SCREENHEIGHT 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 LOCKUP.TF
NOLOCKSHIFT.TF 1SHIFTDOWN.TF 1SHIFTUP.TF 2SHIFTDOWN.TF
2SHIFTUP.TF METADOWN.TF METAUP.TF))
(DECLARE: EVAL@COMPILE
(RPAQQ CTRLDOWN.TF 5)
(RPAQQ CTRLUP.TF 4)
(RPAQQ IGNORE.TF 0)
(RPAQQ EVENT.TF 1)
(RPAQQ LOCKDOWN.TF 10Q)
(RPAQQ LOCKSHIFT.TF 2)
(RPAQQ LOCKUP.TF 7)
(RPAQQ NOLOCKSHIFT.TF 3)
(RPAQQ 1SHIFTDOWN.TF 6)
(RPAQQ 1SHIFTUP.TF 11Q)
(RPAQQ 2SHIFTDOWN.TF 13Q)
(RPAQQ 2SHIFTUP.TF 12Q)
(RPAQQ METADOWN.TF 15Q)
(RPAQQ METAUP.TF 14Q)
(CONSTANTS CTRLDOWN.TF CTRLUP.TF IGNORE.TF EVENT.TF LOCKDOWN.TF LOCKSHIFT.TF LOCKUP.TF NOLOCKSHIFT.TF
1SHIFTDOWN.TF 1SHIFTUP.TF 2SHIFTDOWN.TF 2SHIFTUP.TF METADOWN.TF METAUP.TF)
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \TRANSINDEX MACRO ((KEYNUMBER DOWNFLG)
(COND
(DOWNFLG (IPLUS NKEYS KEYNUMBER))
(T KEYNUMBER))))
)
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD INTERRUPTSTATE ((NIL BITS 5)
(STACKOVERFLOW FLAG)
(STORAGEFULL FLAG)
(WAITINGINTERRUPT FLAG)
(INTCHARCODE BYTE)))
(ACCESSFNS ARMEDINTERRUPTS [(ARMED [NOT (ZEROP (LOGAND (GETBASE \ARMEDINTERRUPTS (FOLDLO DATUM
BITSPERWORD))
(LLSH 1 (IMOD DATUM BITSPERWORD]
(PUTBASE \ARMEDINTERRUPTS (FOLDLO DATUM BITSPERWORD)
(COND
[NEWVALUE (LOGOR (GETBASE \ARMEDINTERRUPTS
(FOLDLO DATUM BITSPERWORD))
(LLSH 1 (IMOD DATUM BITSPERWORD]
(T (LOGAND (GETBASE \ARMEDINTERRUPTS (FOLDLO DATUM
BITSPERWORD))
(LOGXOR (LLSH 1 (IMOD DATUM BITSPERWORD))
177777Q])
]
(* END EXPORTED DEFINITIONS)
[DECLARE: EVAL@COMPILE
(ACCESSFNS TRANSITION ((FLAGS (GETBASEBYTE \TRANSITIONFLAGS DATUM)
(PUTBASEBYTE \TRANSITIONFLAGS DATUM NEWVALUE))
(CODE (GETBASEBYTE \TRANSITIONCODES DATUM)
(PUTBASEBYTE \TRANSITIONCODES DATUM NEWVALUE))
(SHIFTCODE (GETBASEBYTE \TRANSITIONSHIFTCODES DATUM)
(PUTBASEBYTE \TRANSITIONSHIFTCODES DATUM NEWVALUE))))
(ACCESSFNS SHIFTSTATE [[SHIFT (NOT (ZEROP (LOGAND (GETBASEBYTE DATUM 0)
(LOGOR 1SHIFTBIT 2SHIFTBIT]
[1SHIFT [NOT (ZEROP (LOGAND 1SHIFTBIT (GETBASEBYTE DATUM 0]
(PUTBASEBYTE DATUM 0 (COND
(NEWVALUE (LOGOR 1SHIFTBIT (GETBASEBYTE DATUM 0)))
(T (LOGAND (GETBASEBYTE DATUM 0)
(LOGXOR \CHARMASK 1SHIFTBIT]
[2SHIFT [NOT (ZEROP (LOGAND 2SHIFTBIT (GETBASEBYTE DATUM 0]
(PUTBASEBYTE DATUM 0 (COND
(NEWVALUE (LOGOR 2SHIFTBIT (GETBASEBYTE DATUM 0)))
(T (LOGAND (GETBASEBYTE DATUM 0)
(LOGXOR \CHARMASK 2SHIFTBIT]
[LOCK [NOT (ZEROP (LOGAND LOCKBIT (GETBASEBYTE DATUM 0]
(PUTBASEBYTE DATUM 0 (COND
(NEWVALUE (LOGOR LOCKBIT (GETBASEBYTE DATUM 0)))
(T (LOGAND (GETBASEBYTE DATUM 0)
(LOGXOR \CHARMASK LOCKBIT]
[SHIFTORLOCK (NOT (ZEROP (GETBASEBYTE DATUM 0)))
(PUTBASEBYTE DATUM 0 (COND
(NEWVALUE (HELP " Can't turn on SHIFTORLOCK"))
(T 0]
[CTRL (NOT (ZEROP (GETBASEBYTE DATUM 1)))
(PUTBASEBYTE DATUM 1 (COND
(NEWVALUE 1)
(T 0]
(META (NOT (ZEROP (GETBASEBYTE DATUM 2)))
(PUTBASEBYTE DATUM 2 (COND
(NEWVALUE 1)
(T 0])
(BLOCKRECORD RING ((READ WORD)
(WRITE WORD)))
]
(DECLARE: EVAL@COMPILE
(RPAQQ NRINGINDEXWORDS 2)
(CONSTANTS NRINGINDEXWORDS)
)
(RPAQQ SHIFTBITS (1SHIFTBIT 2SHIFTBIT LOCKBIT))
(DECLARE: EVAL@COMPILE
(RPAQQ 1SHIFTBIT 1)
(RPAQQ 2SHIFTBIT 2)
(RPAQQ LOCKBIT 4)
(CONSTANTS 1SHIFTBIT 2SHIFTBIT LOCKBIT)
)
(DECLARE: EVAL@COMPILE
(RPAQ \SYSBUFFER.FIRST (UNFOLD NRINGINDEXWORDS BYTESPERWORD))
(RPAQ \SYSBUFFER.LAST (SUB1 (IPLUS \SYSBUFSIZE (UNFOLD NRINGINDEXWORDS BYTESPERWORD))))
[CONSTANTS (\SYSBUFFER.FIRST (UNFOLD NRINGINDEXWORDS BYTESPERWORD))
(\SYSBUFFER.LAST (SUB1 (IPLUS \SYSBUFSIZE (UNFOLD NRINGINDEXWORDS BYTESPERWORD]
)
(DECLARE: EVAL@COMPILE
(RPAQQ BYTESPERTRANSITION 3)
(RPAQQ NKEYS 160Q)
(CONSTANTS BYTESPERTRANSITION NKEYS)
)
)
(DECLARE: EVAL@COMPILE
(RPAQQ \KEYNAMES ((5 %%)
(4 $)
(6 ~)
(e E)
(7 &)
(d D)
(u U)
(v V)
(0 %))
(k K)
(- %)
(p P)
(/ ?)
(\ %| FONT)
(LF SAME)
(BS <-)
(3 #)
(2 @)
(w W)
(q Q)
(s S)
(a A)
(11Q %()
(i I)
(x X)
(o O)
(l L)
(, <)
(' %")
(%] })
(BLANK-MIDDLE OPEN)
(BLANK-TOP KEYBOARD)
(1 !)
(ESC ESCAPE ->)
(TAB =>)
(f F)
(CTRL PROP'S)
(c C)
(j J)
(b B)
(z Z)
(LSHIFT)
(%. >)
(; :)
(CR <-%|)
(← ↑)
(DEL DELETE)
(SKIP NEXT)
(r R)
(t T)
(g G)
(y Y)
(h H)
(10Q *)
(n N)
(m M)
(LOCK)
(SPACE)
(%[ {)
(= +)
(RSHIFT)
(BLANK-BOTTOM STOP)
(MOVE)
(UNDO)
(UTIL0)
(UTIL1)
(UTIL2)
(UTIL3)
(UTIL4)
(UTIL5)
(UTIL6)
(UTIL7)
(PAD1 LEFTKEY)
(PAD2 LEFTMIDDLEKEY)
(PAD3 MIDDLEKEY)
(PAD4 RIGHTMIDDLEKEY)
(PAD5 RIGHTKEY)
(LEFT RED MOUSERED)
(RIGHT BLUE MOUSEBLUE)
(MIDDLE YELLOW MOUSEYELLOW)
(K40)
(K41)
(K42)
(MARGINS)
(K44)
(K45)
(K46)
(K47)
(K48)
(COPY)
(FIND)
(AGAIN)
(HELP)
(DEF'N EXPAND)
(K4E)
(ALWAYS-ON-1)
(ALWAYS-ON-2)
(CENTER)
(K52)
(BOLD)
(ITALICS)
(UNDERLINE)
(SUPERSCRIPT)
(SUBSCRIPT)
(LARGER SMALLER)
(K59)
(K5A)
(K5B)
(K5C)
(DEFAULTS)
(K5E)
(K5F)))
)
(RPAQQ \ORIGKEYACTIONS ((5 (65Q %% NOLOCKSHIFT))
(4 (64Q $ NOLOCKSHIFT))
(6 (66Q ~ NOLOCKSHIFT))
(e (e E LOCKSHIFT))
(7 (67Q & NOLOCKSHIFT))
(d (d D LOCKSHIFT))
(u (u U LOCKSHIFT))
(v (v V LOCKSHIFT))
(0 (60Q %) NOLOCKSHIFT))
(k (k K LOCKSHIFT))
(- (- - NOLOCKSHIFT))
(p (p P LOCKSHIFT))
(/ (/ ? NOLOCKSHIFT))
(\ (\ %| NOLOCKSHIFT))
(LF (12Q 140Q NOLOCKSHIFT))
(BS (1 1 NOLOCKSHIFT))
(3 (63Q # NOLOCKSHIFT))
(2 (62Q @ NOLOCKSHIFT))
(w (w W LOCKSHIFT))
(q (q Q LOCKSHIFT))
(s (s S LOCKSHIFT))
(a (a A LOCKSHIFT))
(11Q (71Q %( NOLOCKSHIFT))
(i (i I LOCKSHIFT))
(x (x X LOCKSHIFT))
(o (o O LOCKSHIFT))
(l (l L LOCKSHIFT))
(, (, < NOLOCKSHIFT))
(' (' %" NOLOCKSHIFT))
(%] (%] } NOLOCKSHIFT))
(BLANK-MIDDLE (302Q 302Q NOLOCKSHIFT))
(BLANK-TOP (301Q 301Q NOLOCKSHIFT))
(1 (61Q ! NOLOCKSHIFT))
(ESC (33Q 33Q NOLOCKSHIFT))
(TAB (11Q 11Q NOLOCKSHIFT))
(f (f F LOCKSHIFT))
(CTRL CTRLDOWN . CTRLUP)
(c (c C LOCKSHIFT))
(j (j J LOCKSHIFT))
(b (b B LOCKSHIFT))
(z (z Z LOCKSHIFT))
(LSHIFT 1SHIFTDOWN . 1SHIFTUP)
(%. (%. > NOLOCKSHIFT))
(; (; : NOLOCKSHIFT))
(CR (15Q 15Q NOLOCKSHIFT))
(← (← ↑ NOLOCKSHIFT))
(DEL (177Q 177Q NOLOCKSHIFT))
(r (r R LOCKSHIFT))
(t (t T LOCKSHIFT))
(g (g G LOCKSHIFT))
(y (y Y LOCKSHIFT))
(h (h H LOCKSHIFT))
(10Q (70Q * NOLOCKSHIFT))
(n (n N LOCKSHIFT))
(m (m M LOCKSHIFT))
(LOCK LOCKDOWN . LOCKUP)
(SPACE (40Q 40Q NOLOCKSHIFT))
(%[ (%[ { NOLOCKSHIFT))
(= (= + NOLOCKSHIFT))
(RSHIFT 2SHIFTDOWN . 2SHIFTUP)
(BLANK-BOTTOM (303Q 303Q NOLOCKSHIFT))
(RED EVENT . EVENT)
(BLUE EVENT . EVENT)
(YELLOW EVENT . EVENT)
(SUPERSCRIPT LOCKDOWN)
(SUBSCRIPT LOCKUP)
(NEXT (%( %[ NOLOCKSHIFT))
(UNDO (%) %] NOLOCKSHIFT))))
(RPAQQ \MODIFIED.KEYACTIONS ((BLANK-MIDDLE (302Q 302Q NOLOCKSHIFT) . IGNORE)))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \SYSBUFFER \LONGSYSBUF \TRANSITIONFLAGS \TRANSITIONCODES \TRANSITIONSHIFTCODES
\ARMEDINTERRUPTS \INTERRUPTSTATE \SHIFTSTATE \MODIFIED.KEYACTIONS \EVENTSTATUS \EVENTQUEUE
\RCLKSECOND \LASTUSERACTION \MOUSECHORDTICKS)
)
(* Key interpretation)
(DEFINEQ
(KEYACTION
[LAMBDA (KEYNAME ACTIONS) (* lmm "30-MAR-83 20:41")
(PROG ((NUMB (\KEYNAMETONUMBER KEYNAME)))
(RETURN (CONS [\KEYACTION1 (\TRANSINDEX NUMB T)
(AND ACTIONS (OR (CAR ACTIONS)
(QUOTE IGNORE]
(\KEYACTION1 (\TRANSINDEX NUMB NIL)
(AND ACTIONS (OR (CDR ACTIONS)
(QUOTE IGNORE])
(\KEYACTION1
[LAMBDA (TI ACTION) (* lmm "31-JUL-82 22:34")
(PROG1 (SELECTC (fetch (TRANSITION FLAGS) of TI)
(IGNORE.TF (QUOTE IGNORE))
[(LIST LOCKSHIFT.TF NOLOCKSHIFT.TF)
(LIST (fetch (TRANSITION CODE) of TI)
(fetch (TRANSITION SHIFTCODE) of TI)
(COND
((EQ LOCKSHIFT.TF (fetch (TRANSITION FLAGS) of 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))
(METADOWN.TF (QUOTE METADOWN))
(METAUP.TF (QUOTE METAUP))
(SHOULDNT))
(SELECTQ ACTION
((NIL NOCHANGE))
(IGNORE (replace (TRANSITION FLAGS) of TI with IGNORE.TF))
(EVENT (replace (TRANSITION FLAGS) of TI with EVENT.TF))
(CTRLUP (replace (TRANSITION FLAGS) of TI with CTRLUP.TF))
(CTRLDOWN (replace (TRANSITION FLAGS) of TI with CTRLDOWN.TF))
(1SHIFTUP (replace (TRANSITION FLAGS) of TI with 1SHIFTUP.TF))
(1SHIFTDOWN (replace (TRANSITION FLAGS) of TI with 1SHIFTDOWN.TF))
(2SHIFTUP (replace (TRANSITION FLAGS) of TI with 2SHIFTUP.TF))
(2SHIFTDOWN (replace (TRANSITION FLAGS) of TI with 2SHIFTDOWN.TF))
(LOCKUP (replace (TRANSITION FLAGS) of TI with LOCKUP.TF))
(LOCKDOWN (replace (TRANSITION FLAGS) of TI with LOCKDOWN.TF))
(METAUP (replace (TRANSITION FLAGS) of TI with METAUP.TF))
(METADOWN (replace (TRANSITION FLAGS) of TI with METADOWN.TF))
(PROG (CODE SHIFTCODE ACT)
(COND
((AND [SMALLP (SETQ CODE (\GETCHARCODE (CAR (LISTP ACTION]
[SMALLP (SETQ SHIFTCODE (\GETCHARCODE (CAR (SETQ ACT
(LISTP (CDR ACTION]
(OR (NULL (SETQ ACT (CDR ACT)))
(LISTP ACT))
(SELECTQ (CAR ACT)
((LOCKSHIFT T)
(replace (TRANSITION FLAGS) of TI with LOCKSHIFT.TF))
((NOLOCKSHIFT NIL)
(replace (TRANSITION FLAGS) of TI with NOLOCKSHIFT.TF))
NIL))
(replace (TRANSITION CODE) of TI with CODE)
(replace (TRANSITION SHIFTCODE) of TI with SHIFTCODE))
(T (\ILLEGAL.ARG ACTION])
(KEYDOWNP
[LAMBDA (KEYNAME) (* rmk: " 1-JUN-81 12:28")
(* T if the indicated key is instantaneously down.)
(KEYDOWNP1 (\KEYNAMETONUMBER KEYNAME])
(KEYDOWNP1
[LAMBDA (KEYNUMBER) (* bvm: "30-SEP-82 17:50")
(* Assumes that KEYNUMBER is a valid key number. -- This function should be eliminated when all callers of
KEYDOWNP have been recompiled, since KEYDOWNP1 now macros out)
(PROG NIL
(RETURN (ZEROP (LOGAND (LRSH (LLSH 1 17Q)
(MOD KEYNUMBER BITSPERWORD))
(\GETBASE (SELECTQ (FOLDLO KEYNUMBER BITSPERWORD)
(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])
(\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])
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DEFINEQ
(\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])
)
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS KEYDOWNP MACRO [ARGS (COND
[(AND (LISTP (CAR ARGS))
(EQ (CAAR ARGS)
(QUOTE QUOTE)))
(LIST (QUOTE KEYDOWNP1)
(\KEYNAMETONUMBER (CADAR ARGS]
(T (QUOTE IGNOREMACRO])
(PUTPROPS KEYDOWNP1 MACRO [OPENLAMBDA
(KEYNUMBER)
(DECLARE (GLOBALVARS \EM.KBDAD0 \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3
\EM.UTILIN \EM.KBDAD4 \EM.KBDAD5))
(PROG NIL
(RETURN (ZEROP (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])
)
(* END EXPORTED DEFINITIONS)
(DEFINEQ
(\SHOWCOLORCURSOR
[LAMBDA (X Y) (* rrb "25-FEB-83 10:15")
(* puts the cursor bitmap on the screen at location X Y)
(DECLARE (GLOBALVARS \MOUSEHOTSPOTX \MOUSEHOTSPOTY \COLORCURSORWIDTH \COLORSCREENCURSORLINEBASE
\COLORSCREENCURSORLINE \COLORCURSORBASE \COLORSCREENWIDTHINBITS
\COLORSCREENRASTERWIDTH \COLORCURSORRASTERWIDTH \ColorCursorBBT))
(* The coordinate operations may seem weird in this function because they are done in Alto bitmap coordinates {the
ones that the cursor positions are kept in} that has Y as 0 at the top of the screen.)
(PROG ((X (IDIFFERENCE X \MOUSEHOTSPOTX))
(Y (IDIFFERENCE Y (IDIFFERENCE (SUB1 \COLORCURSORHEIGHT)
\MOUSEHOTSPOTY)))
(XBASE 0)
(YBASE 0)
(WIDTH \COLORCURSORWIDTH)
(HEIGHT \COLORCURSORHEIGHT))
[COND
((IGREATERP 0 X) (* cursor is to the left of the screen.)
(SETQ XBASE (ITIMES (IMINUS X)
(COLORNUMBERBITSPERPIXEL)))
(SETQ WIDTH (IDIFFERENCE WIDTH XBASE))
(SETQ X 0))
((IGREATERP (IPLUS (SETQ X (\BITADDRESSOFPIXEL (COLORNUMBERBITSPERPIXEL)
X))
WIDTH)
\COLORSCREENWIDTHINBITS) (* some of the cursor is off the screen to the right.)
(SETQ WIDTH (IDIFFERENCE \COLORSCREENWIDTHINBITS X]
[COND
((IGREATERP 0 Y) (* cursor is to the above of the screen.)
(SETQ YBASE (IMINUS Y))
(SETQ HEIGHT (IPLUS \COLORCURSORHEIGHT Y))
(SETQ Y 0))
((IGREATERP (IPLUS Y \COLORCURSORHEIGHT)
COLORSCREENHEIGHT) (* some of the cursor is off the screen to the right.)
(SETQ HEIGHT (IDIFFERENCE COLORSCREENHEIGHT Y]
(UNINTERRUPTABLY
[COND
((EQ \COLORSCREENCURSORLINE Y)
(* the base address of the cursor destination in the color screen bitmap is incremented to avoid large number
arithmetic that results because the color screen is more that one segment.)
)
[(IGREATERP \COLORSCREENCURSORLINE Y) (* subtract the line length from the base enough times)
(bind (MINUSRW ←(IMINUS \COLORSCREENRASTERWIDTH)) until (EQ \COLORSCREENCURSORLINE
Y)
do (SETQ \COLORSCREENCURSORLINE (SUB1 \COLORSCREENCURSORLINE))
(SETQ.NOREF \COLORSCREENCURSORLINEBASE (\ADDBASE \COLORSCREENCURSORLINEBASE
MINUSRW]
(T (* add line length to base)
(until (EQ \COLORSCREENCURSORLINE Y)
do (SETQ \COLORSCREENCURSORLINE (ADD1 \COLORSCREENCURSORLINE))
(SETQ.NOREF \COLORSCREENCURSORLINEBASE (\ADDBASE \COLORSCREENCURSORLINEBASE
\COLORSCREENRASTERWIDTH]
(replace (PILOTBBT PBTWIDTH) of \ColorCursorBBT with WIDTH)
(replace (PILOTBBT PBTHEIGHT) of \ColorCursorBBT with HEIGHT)
(replace (PILOTBBT PBTDEST) of \ColorCursorBBT with (\ADDBASE
\COLORSCREENCURSORLINEBASE
(FOLDLO X BITSPERWORD)))
(replace (PILOTBBT PBTDESTBIT) of \ColorCursorBBT with (IMOD X BITSPERWORD))
[replace (PILOTBBT PBTSOURCE) of \ColorCursorBBT with (\ADDBASE \COLORCURSORBASE
(IPLUS (ITIMES YBASE
\COLORCURSORRASTERWIDTH)
(FOLDLO XBASE
BITSPERWORD]
[replace (PILOTBBT PBTSOURCEBIT) of \ColorCursorBBT with (COND
((EQ XBASE 0)
0)
(T (IMOD XBASE BITSPERWORD]
(\PILOTBITBLT \ColorCursorBBT 0))])
)
(RPAQ? \COLORCURSORBM )
(RPAQ? \COLORCURSORDOWN )
(RPAQ? \ColorCursorBBT )
(RPAQ? \COLORCURSOR )
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS COLORNUMBERBITSPERPIXEL MACRO (NIL (DECLARE (GLOBALVARS \COLORDISPLAYBITSPERPIXEL))
\COLORDISPLAYBITSPERPIXEL))
(PUTPROPS \BITADDRESSOFPIXEL MACRO [OPENLAMBDA (BITSPERPIXEL PIXEL)
(COND
((EQ BITSPERPIXEL 4)
(LLSH PIXEL 2))
(T (LLSH PIXEL 3])
(PUTPROPS .TAKE.DOWN.COLOR.CURSOR MACRO (NIL (* uses same bitblt table that the cursor was put up
with to take it down.)
(\PILOTBITBLT \ColorCursorBBT 0)))
)
(DECLARE: EVAL@COMPILE
(RPAQQ COLORSCREENWIDTH 640)
(RPAQQ COLORSCREENHEIGHT 480)
(CONSTANTS (COLORSCREENWIDTH 640)
(COLORSCREENHEIGHT 480))
)
(* END EXPORTED DEFINITIONS)
(* A raw keyboard device/stream)
(DEFINEQ
(\INIT.KEYBOARD.STREAM
(LAMBDA NIL (* JonL "16-NOV-83 08:33")
(DECLARE (GLOBALVARS \KEYBOARD.DEVICE \KEYBOARD.STREAM))
(\DEFINEDEVICE (QUOTE KEYBOARD)
(SETQ \KEYBOARD.DEVICE (create FDEV
DEVICENAME ←(QUOTE KEYBOARD)
CLOSEFILE ←(FUNCTION NILL)
EVENTFN ←(FUNCTION NILL)
BIN ←(FUNCTION (LAMBDA (STREAM)
(PROGN (until (\SYSBUFP) do (BLOCK))
(\GETSYSBUF))))
BOUT ←(FUNCTION (LAMBDA (STREAM CHAR)
(\PUTSYSBUF CHAR)))
PEEKBIN ←(FUNCTION \PEEKSYSBUF)
READP ←(FUNCTION \SYSBUFP)
GETFILEPTR ←(FUNCTION ZERO)
GETEOFPTR ←(FUNCTION \KEYBOARD.GETEOFPTR)
BACKFILEPTR ←(FUNCTION \KEYBOARD.BACKFILEPTR)
EOFP ←(FUNCTION NILL))))
(SETQ \KEYBOARD.STREAM (create STREAM
USERCLOSEABLE ← NIL
USERVISIBLE ← NIL
FULLFILENAME ←(QUOTE KEYBOARD:)
DEVICE ← \KEYBOARD.DEVICE
ACCESS ←(QUOTE BOTH)))))
(\KEYBOARD.GETEOFPTR
(LAMBDA (STREAM) (* JonL "16-NOV-83 08:23")
(* Returns the total number of characters resident in
this process's keyboard buffer)
(if (TTY.PROCESSP)
then (if (ZEROP (fetch (RING READ) of \SYSBUFFER))
then (* Empty)
0
else (IPLUS (LENGTH \LONGSYSBUF)
(IDIFFERENCE (fetch (RING WRITE) of \SYSBUFFER)
(fetch (RING READ) of \SYSBUFFER))))
elseif (THIS.PROCESS)
then (LENGTH (fetch PROCTYPEAHEAD of (THIS.PROCESS)))
else (SHOULDNT))))
(\KEYBOARD.BACKFILEPTR
(LAMBDA (STREAM) (* JonL "16-NOV-83 08:49")
(if (AND (TTY.PROCESSP)
(NOT \LONGSYSBUF))
then (PROG ((R (fetch (RING READ) of \SYSBUFFER))
(W (fetch (RING WRITE) of \SYSBUFFER)))
(if (ZEROP R)
then (* Empty)
(replace (RING READ) of \SYSBUFFER with (SUB1 W))
elseif (EQ R W)
then (* Sigh, buffer full)
else (replace (RING READ) of \SYSBUFFER with (SUB1 R))))
else (ERROR STREAM (QUOTE BACKFILEPTR)))))
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(\INIT.KEYBOARD.STREAM)
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \KEYBOARD.DEVICE \KEYBOARD.STREAM)
)
(* END EXPORTED DEFINITIONS)
(* Hook for a periodic interrupt)
(DEFINEQ
(\PERIODIC.INTERRUPTFRAME
[LAMBDA NIL
(DECLARE (GLOBALVARS \PERIODIC.INTERRUPT)) (* bvm: "11-NOV-82 15:07")
(APPLY* \PERIODIC.INTERRUPT])
(\CAUSE.PERIODIC.INTERRUPT
[LAMBDA (CNTXT) (* lmm "17-Apr-84 05:51")
(PROG ((FRAME (\GETBASE \InterfacePage CNTXT))
NXT)
(COND
((ILESSP FRAME (fetch (IFPAGE StackBase) of \InterfacePage))
(RETURN)))
(SETQ NXT (fetch (FX NEXTBLOCK) of FRAME))
(CHECK (fetch (FX CHECKED) of FRAME)
(type? FSB NXT))
(\PUTBASE \InterfacePage CNTXT (OR (\MAKEFRAME (FUNCTION \PERIODIC.INTERRUPTFRAME)
NXT
(IPLUS NXT (fetch (FSB SIZE) of NXT))
FRAME FRAME)
(RETURN)))
(RETURN T])
)
(RPAQQ \PERIODIC.INTERRUPT NIL)
(RPAQ? \PERIODIC.INTERRUPT.FREQUENCY 60)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(* cursor and mouse related functions.)
(DEFINEQ
(ADJUSTCURSORPOSITION
[LAMBDA (DELTAX DELTAY) (* rrb "16-NOV-82 11:11")
(COND
[(POSITIONP DELTAX)
(\SETCURSORPOSITION (IPLUS (fetch XCOORD of DELTAX)
(\XMOUSECOORD))
(IPLUS (fetch YCOORD of DELTAX)
(\YMOUSECOORD]
(T (\SETCURSORPOSITION (IPLUS (OR DELTAX 0)
(\XMOUSECOORD))
(IPLUS (OR DELTAY 0)
(\YMOUSECOORD])
(CREATEPOSITION
[LAMBDA NIL (* lmm " 7-MAR-82 23:27")
(create POSITION])
(CURSOR
[LAMBDA (NEWCURSOR INVERTFLG) (* rrb " 4-DEC-82 17:51")
(* 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))
(PROG1 (create CURSOR
CURSORBITMAP ←[BITMAPCOPY (COND
(\COLORCURSORBM
(* cursor is on color display, get bw copy of cursor
bitmap since the hardware one is empty.)
\COLORCURSOR)
(T (CURSORBITMAP]
CURSORHOTSPOT ←(CURSORHOTSPOT))
(COND
((EQ NEWCURSOR T)
(SETQ NEWCURSOR DEFAULTCURSOR)))
(COND
((type? CURSOR NEWCURSOR)
(SETCURSOR NEWCURSOR INVERTFLG])
(CURSORCREATE
[LAMBDA (BITMAP X Y) (* lmm "11-MAR-82 00:57")
(* creates a cursor from a bitmap. X and Y specify the hotspot.)
(PROG ((BM (BITMAPCREATE CURSORWIDTH CURSORHEIGHT)))
(BITBLT (OR BITMAP (CURSORBITMAP))
0 0 BM 0 0 CURSORWIDTH CURSORHEIGHT (QUOTE INPUT)
(QUOTE REPLACE))
(RETURN (create CURSOR
CURSORBITMAP ← BM
CURSORHOTSPOT ←(create POSITION
XCOORD ←(COND
((POSITIONP X)
(fetch XCOORD of X))
(T (OR (FIXP X)
0)))
YCOORD ←(COND
((POSITIONP X)
(fetch YCOORD of X))
(T (OR (FIXP Y)
(SUB1 CURSORHEIGHT])
(CURSORHOTSPOT
[LAMBDA (NEWPOSITION) (* rrb "14-JAN-81 16:16")
(* returns the current cursor hot spot and sets the hot spot to NEWPOSITON if one
is given.)
(PROG1 (create POSITION
XCOORD ← \MOUSEHOTSPOTX
YCOORD ← \MOUSEHOTSPOTY)
(COND
((POSITIONP NEWPOSITION)
(SETQ \MOUSEHOTSPOTX (fetch XCOORD of NEWPOSITION))
(SETQ \MOUSEHOTSPOTY (fetch YCOORD of NEWPOSITION])
(CURSORPOSITION
[LAMBDA (NEWPOSITION DISPLAYSTREAM OLDPOSITION) (* rmk: "23-AUG-83 18:18")
(PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM)))
(OR (POSITIONP OLDPOSITION)
(SETQ OLDPOSITION (create POSITION)))
(freplace XCOORD of OLDPOSITION with (\DSPUNTRANSFORMX (\XMOUSECOORD)
DD))
(freplace YCOORD of OLDPOSITION with (\DSPUNTRANSFORMY (\YMOUSECOORD)
DD))
(COND
((POSITIONP NEWPOSITION)
(\SETCURSORPOSITION (\DSPTRANSFORMX (fetch XCOORD of NEWPOSITION)
DD)
(\DSPTRANSFORMY (fetch YCOORD of NEWPOSITION)
DD)))
(NEWPOSITION (\ILLEGAL.ARG NEWPOSITION)))
(RETURN OLDPOSITION])
(\SETCURSORPOSITION
[LAMBDA (XPOS YPOS) (* bvm: "30-JUL-83 15:28")
(* sets cursor position, adjusts for hotspot and tty
region limits. XPOS and YPOS are the screen coordinates
of the hotspot location.)
(DECLARE (GLOBALVARS \MOUSEHOTSPOTX \MOUSEHOTSPOTY SCREENWIDTH))
(* if the color cursor is running, the position is the
real position so don't correct for the hotspot.)
(* Clip coordinates to between 0 and
SCREENWIDTH,CURSORYMAX)
[COND
[\COLORCURSORBM (SETQ XPOS (COND
((ILESSP XPOS 0)
0)
((IGREATERP XPOS (CONSTANT (SUB1 COLORSCREENWIDTH)))
(CONSTANT (SUB1 COLORSCREENWIDTH)))
(T XPOS)))
(SETQ YPOS (IDIFFERENCE (CONSTANT (SUB1 COLORSCREENHEIGHT))
(COND
((ILESSP YPOS 0)
0)
((IGREATERP YPOS (CONSTANT (SUB1 COLORSCREENHEIGHT)))
(CONSTANT (SUB1 COLORSCREENHEIGHT)))
(T YPOS]
(T (SETQ XPOS (UNSIGNED (IDIFFERENCE (COND
((ILESSP XPOS 0)
0)
((IGEQ XPOS SCREENWIDTH)
(SUB1 SCREENWIDTH))
(T XPOS))
\MOUSEHOTSPOTX)
BITSPERWORD))
(* YPOS is reflected around CURSORYMAX because the screen has (0,0) as the upper left corner.
Complicated by the fact that it needs to position the upper left corner of the cursor. (IMINUS CURSORHEIGHT)
allows the cursor to move off the bottom of the screen. When moved to LISP, cursor tracking should allow the
hotspot to be anywhere on the screen.)
(SETQ YPOS (UNSIGNED (IDIFFERENCE (IPLUS CURSORYMAX \MOUSEHOTSPOTY)
(COND
((ILESSP YPOS 0)
0)
((IGREATERP YPOS SCREENHEIGHT)
SCREENHEIGHT)
(T YPOS)))
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])
(FLIPCURSOR
[LAMBDA NIL (* lmm "13-MAY-82 00:22")
(PROG ((ADDR \EM.CURSORBITMAP))
(FRPTQ CURSORHEIGHT [\PUTBASE ADDR 0 (LOGXOR (\GETBASE ADDR 0)
(CONSTANT (SUB1 (EXPT 2 CURSORWIDTH]
(SETQ ADDR (\ADDBASE ADDR 1])
(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])
(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])
(SETCURSOR
[LAMBDA (NEWCURSOR INVERTFLG) (* rrb "22-DEC-82 16:09")
(* version of SETCURSOR that knows about the possibility
of the cursor being on the color screen.)
(OR (type? CURSOR NEWCURSOR)
(\ILLEGAL.ARG NEWCURSOR))
(COND
(\COLORCURSORBM (* cursor is on the color screen)
(\TAKEDOWNCOLORCURSOR)
(SETQ \MOUSEHOTSPOTY (fetch CURSORHOTSPOTY of NEWCURSOR))
(SETQ \MOUSEHOTSPOTX (fetch CURSORHOTSPOTX of NEWCURSOR))
(\SETCOLORCURSORBM (fetch (CURSOR CURSORBITMAP) of NEWCURSOR)))
(T (BITBLT (fetch CURSORBITMAP of NEWCURSOR)
0 0 (CURSORBITMAP)
0 0 CURSORWIDTH CURSORHEIGHT (COND
(INVERTFLG (QUOTE INVERT))
(T (QUOTE INPUT)))
(QUOTE REPLACE)) (* don't need to adjust the color cursor because it is
kept in hotspot independent terms.)
(ADJUSTCURSORPOSITION (IDIFFERENCE \MOUSEHOTSPOTX (fetch CURSORHOTSPOTX of NEWCURSOR))
(IDIFFERENCE \MOUSEHOTSPOTY (fetch CURSORHOTSPOTY of NEWCURSOR)))
(* set after adjustment to avoid confusion about hotspot
during adjustment.)
(SETQ \MOUSEHOTSPOTY (fetch CURSORHOTSPOTY of NEWCURSOR))
(SETQ \MOUSEHOTSPOTX (fetch CURSORHOTSPOTX of NEWCURSOR])
)
(DEFINEQ
(GETMOUSESTATE
[LAMBDA NIL (* bvm: " 5-Apr-84 17:05")
(* Reads the current state of the mouse and keyboard)
(SETQ LASTMOUSEX (\XMOUSECOORD))
(SETQ LASTMOUSEY (\YMOUSECOORD))
(SETQ LASTMOUSEBUTTONS (LOGOR (COND
((KEYDOWNP (QUOTE CENTER))
\MOUSE.MIDDLEBIT)
(T 0))
(LOGXOR (LOGAND (\GETBASE \EM.UTILIN 0)
\MOUSE.ALLBITS)
\MOUSE.ALLBITS)))
(SETQ LASTMOUSETIME (fetch (FIXP LONUM) of (\CLOCK0 \MOUSETIMEBOX)))
(SETQ LASTKEYBOARD (\EVENTKEYS))
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 CURSORHEIGHT 16)
(RPAQQ CURSORWIDTH 16)
(CONSTANTS (CURSORHEIGHT 16)
(CURSORWIDTH 16))
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS FLIPCURSORBAR MACRO [(X) (* Flip bar of cursor during this.)
(\PUTBASE \EM.CURSORBITMAP X (LOGXOR (\GETBASE \EM.CURSORBITMAP X)
(CONSTANT MAX.SMALL.INTEGER])
)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS BUTTONCHARCODE)
)
(DECLARE: EVAL@COMPILE
(ADDTOVAR GLOBALVARS LASTMOUSEX LASTMOUSEY LASTMOUSEBUTTONS LASTMOUSETIME LASTKEYBOARD)
)
(* END EXPORTED DEFINITIONS)
(RPAQ? \MOUSEHOTSPOTX 0)
(RPAQ? \MOUSEHOTSPOTY 15)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \MOUSEHOTSPOTX \MOUSEHOTSPOTY \MOUSETIMEBOX \COLORCURSOR)
)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS \SETMOUSEXY MACRO [(XPOS YPOS)
(PROGN (SELECTC \MACHINETYPE
(\DANDELION (do (PROGN (replace NEWMOUSEX of \IOPAGE
with XPOS)
(replace NEWMOUSEY of \IOPAGE
with YPOS))
repeatuntil (ILESSP (fetch NEWMOUSESTATE
of \IOPAGE)
32768))
(* smash position until mouse says it is not busy)
(replace NEWMOUSEX of \IOPAGE with XPOS)
(replace NEWMOUSEY of \IOPAGE with YPOS)
(replace NEWMOUSESTATE of \IOPAGE
with 32768))
NIL)
(PROGN (\PUTBASE \EM.MOUSEX 0 XPOS)
(\PUTBASE \EM.MOUSEY 0 YPOS])
)
(* END EXPORTED DEFINITIONS)
(DECLARE: EVAL@COMPILE
(PUTPROPS \XMOUSECOORD MACRO [NIL (COND
(\COLORCURSORBM (\GETBASE \EM.CURSORX 0))
(T (IPLUS \MOUSEHOTSPOTX (SIGNED (\GETBASE \EM.CURSORX 0)
BITSPERWORD])
(PUTPROPS \YMOUSECOORD MACRO (NIL (IDIFFERENCE (COND
(\COLORCURSORBM
(* color cursor is on.)
(CONSTANT (SUB1 COLORSCREENHEIGHT)))
(T (IPLUS \MOUSEHOTSPOTY CURSORYMAX)))
(SIGNED (\GETBASE \EM.CURSORY 0)
BITSPERWORD))))
)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQ \SFPosition (CREATEPOSITION))
)
(DECLARE: DOEVAL@COMPILE
(RPAQQ SCREENHEIGHT 808)
)
(* Queued mouse)
(DEFINEQ
(BKMOUSEBUF
[LAMBDA (EVENTLST) (* lmm "30-MAR-83 20:42")
(* restores a list of mouse events into the mouse queue.)
(for EVENT in (REVERSE EVENTLST) bind WPTR R (W ←(fetch (RING WRITE) of \EVENTQUEUE))
do (COND
((EQ W (SETQ R (fetch (RING READ) of \EVENTQUEUE)))
(* Queue full)
(RETURN))) (* calculate pointer to next mouse event)
(SETQ WPTR (ADDBASE \EVENTQUEUE W))
(replace (EVENTPTR MouseX) of WPTR with (fetch MOUSEX of EVENT))
(replace (EVENTPTR MouseY) of WPTR with (fetch MOUSEY of EVENT))
(replace (EVENTPTR MouseButtons) of WPTR with (fetch MOUSEBUTTONS of EVENT))
(replace (EVENTPTR MouseKeys) of WPTR with (fetch KEYBOARD of EVENT))
(replace (EVENTPTR MouseTime) of WPTR with (fetch MOUSETIME of EVENT))
(AND (ZEROP R)
(replace (RING READ) of \EVENTQUEUE with W))
(replace (RING WRITE) of \EVENTQUEUE with (SETQ W (COND
((EQ \EVENTQUEUE.LAST W)
\EVENTQUEUE.FIRST)
(T (IPLUS EVENTLENGTH W])
(CLEARMOUSEBUF
[LAMBDA (FLG) (* lmm "30-MAR-83 20:42")
(* clears the event queue. If FLG is T, the events are saved.)
(COND
((NEQ NO.EV (fetch EVENTSENABLED of \EVENTQUEUE))
(* save events)
(COND
[FLG (SETQ \ClearedMouseEvents
(while (GETMOUSEEVENT FLG)
collect (create MOUSEEVENT
MOUSEX ← LASTMOUSEX
MOUSEY ← LASTMOUSEY
MOUSEBUTTONS ← LASTMOUSEBUTTONS
KEYBOARD ← LASTKEYBOARD
MOUSETIME ← LASTMOUSETIME]
(T (SETQ \ClearedMouseEvents NIL)
(replace (RING READ) of \EVENTQUEUE with 0])
(ENABLEMOUSE
[LAMBDA (#EVENTS CHARCODE) (* lmm "11-FEB-83 08:05")
(* starts the keeping of mouse events on transition of buttons. CHARCODE if non-NIL is the character code that is
put in the keyboard stream to coordinate mouse clicks with typing. Sets the variable \MouseEnabled so that mouse
will be reenabled after logout.)
(* changed to return dotted pair of previous setting.)
(PROG1 \MouseEnabled (COND
((NULL #EVENTS)
(replace EVENTSENABLED of \EVENTSTATUS with NO.EV)
(SETQ \MouseEnabled))
(T (PROG [(CC (OR (SMALLP (\GETCHARCODE CHARCODE))
(\ILLEGAL.ARG CHARCODE]
(* allow CON **S of #events and charcode.)
[COND
((LISTP #EVENTS)
(SETQ CHARCODE (OR (NUMBERP CHARCODE)
(CDR #EVENTS)))
(SETQ #EVENTS (CAR #EVENTS]
(COND
((IGREATERP #EVENTS 0)
(replace (RING READ) of \EVENTQUEUE with 0)
(replace EVENTSENABLED of \EVENTSTATUS
with (COND
(CC (replace EVENTCHARCODE of \EVENTSTATUS with CC)
CHAR.EV)
(T YES.EV)))
(SETQ BUTTONCHARCODE CC)
(SETQ \MouseEnabled (CONS #EVENTS CC)))
(T (\ILLEGAL.ARG #EVENTS])
(GETMOUSEEVENT
[LAMBDA (FLG) (* lmm "30-MAR-83 20:42")
(* Returns NIL if no event is waiting, otherwise returns time of that event. If FLG=NIL, used as a predicate and
does not set the state variables corresonding to the event, otherwise, sets lastmousex, lastmousey etc.)
(PROG (RPTR (R (fetch (RING READ) of \EVENTQUEUE)))
(RETURN (COND
((ZEROP R)
NIL)
(FLG (SETQ RPTR (ADDBASE \EVENTQUEUE R))
(SETQ LASTMOUSEX (fetch (EVENTPTR MouseX) of RPTR))
(SETQ LASTMOUSEY (fetch (EVENTPTR MouseY) of RPTR))
(SETQ LASTMOUSEBUTTONS (fetch (EVENTPTR MouseButtons) of RPTR))
(SETQ LASTMOUSETIME (fetch (EVENTPTR MouseTime) of RPTR))
(SETQ LASTKEYBOARD (fetch (EVENTPTR MouseKeys) of RPTR))
(AND [EQ (fetch (RING WRITE) of \EVENTQUEUE)
(replace (RING READ) of \EVENTQUEUE
with (COND
((EQ R \EVENTQUEUE.LAST)
\EVENTQUEUE.FIRST)
(T (IPLUS EVENTLENGTH R]
(replace (RING READ) of \EVENTQUEUE with 0))
LASTMOUSETIME)
(T (fetch (EVENTPTR MouseTime) of (ADDBASE \EVENTQUEUE R])
(MOUSEBUF
[LAMBDA (FLG) (* returns the internal buffer of mouse events.)
(COND
(FLG \ClearedMouseEvents)
(T (SETQ \ClearedMouseEvents NIL])
(\PUTEVENTQUEUE
[LAMBDA (CHAR) (* lmm "10-JUL-83 12:14")
(PROG (WPTR (R (fetch (RING READ) of \EVENTQUEUE))
(W (fetch (RING WRITE) of \EVENTQUEUE)))
(RETURN (COND
((EQ R W) (* Full)
NIL)
((OR (NULL CHAR)
(\PUTSYSBUF CHAR))
(SETQ WPTR (\ADDBASE \EVENTQUEUE W))
(replace (EVENTPTR MouseX) of WPTR with (\XMOUSECOORD))
(replace (EVENTPTR MouseY) of WPTR with (\YMOUSECOORD))
[replace MouseButtons of WPTR with (LOGAND 255 (LOGXOR -1 (\GETBASE \EM.UTILIN
0]
[replace MouseTime of WPTR with (fetch (FIXP LONUM)
of (LOCF (fetch LASTUSERACTION of \MISCSTATS]
(replace MouseKeys of WPTR with (\EVENTKEYS))
(AND (ZEROP R)
(replace (RING READ) of \EVENTQUEUE with W))
(* Return random non-NIL value to indicate success for
BKSYSBUF)
(replace (RING WRITE) of \EVENTQUEUE with (COND
((EQ \EVENTQUEUE.LAST W)
\EVENTQUEUE.FIRST)
(T (IPLUS EVENTLENGTH W])
(\ResetMouseQueue
[LAMBDA NIL (* lmm "18-APR-80 17:36")
(replace MouseQueueOUT of \MouseEventQueue with (fetch MouseQueueIN of \MouseEventQueue))
NIL])
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQQ \MouseEnabled NIL)
(RPAQQ \MouseQueueAddrLo 51712)
(RPAQQ \MouseQueueOverhead 4)
(RPAQQ \SingleMouseEvent NIL)
(RPAQQ \MouseEventQueue NIL)
(RPAQQ \ClearedMouseEvents NIL)
(RPAQQ BUTTONCHARCODE NIL)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \MouseQueueAddrLo \MouseEventQueue \MouseQueueOverhead \SingleMouseEvent
\MouseEnabled \DISPLAYREGION \ClearedMouseEvents)
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(BLOCKRECORD MOUSEQUEUE ((MouseQueueIN WORD)
(MouseQueueOUT WORD)
(MouseQueueFIRST WORD)
(MouseQueueLAST WORD)))
(BLOCKRECORD MOUSEPTR ((AbsoluteMouseX WORD)
(AbsoluteMouseY WORD)
(MouseButtons WORD)
(MouseTime WORD)
(MouseKeys WORD))
[ACCESSFNS ((MouseX (IPLUS (fetch AbsoluteMouseX of DATUM)
\MOUSEHOTSPOTX))
(MouseY (IPLUS (COND
((IGREATERP (fetch AbsoluteMouseY of DATUM)
32768)
(* mouse will wrap around at bottom of screen if the
ball is rolling.)
0)
(T (fetch AbsoluteMouseY of DATUM)))
\MOUSEHOTSPOTY]
(* this is only for non-WIND version!)
)
]
(DECLARE: EVAL@COMPILE
(RPAQQ \MouseEventLength 5)
(CONSTANTS \MouseEventLength)
)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD EVENTPTR ((MouseX WORD)
(MouseY WORD)
(MouseButtons WORD)
(MouseTime WORD)
(MouseKeys WORD)))
(BLOCKRECORD EVENTSTATUS ((EVENTSENABLED BYTE)
(EVENTCHARCODE BYTE)))
]
(DECLARE: EVAL@COMPILE
(RPAQQ NO.EV 0)
(RPAQQ CHAR.EV 1)
(RPAQQ YES.EV 2)
(CONSTANTS NO.EV CHAR.EV YES.EV)
)
(DECLARE: EVAL@COMPILE
(RPAQQ EVENTLENGTH 5)
(RPAQ \EVENTQUEUE.FIRST NRINGINDEXWORDS)
(RPAQ \EVENTQUEUE.LAST [IPLUS NRINGINDEXWORDS (ITIMES EVENTLENGTH
(SUB1 (IQUOTIENT (IDIFFERENCE
(UNFOLD 2 WORDSPERPAGE)
(IPLUS 2 1 (FOLDHI
\SYSBUFFER.LAST
BYTESPERWORD)
1 NRINGINDEXWORDS))
EVENTLENGTH])
[CONSTANTS EVENTLENGTH (\EVENTQUEUE.FIRST NRINGINDEXWORDS)
(\EVENTQUEUE.LAST (IPLUS NRINGINDEXWORDS
(ITIMES EVENTLENGTH (SUB1 (IQUOTIENT (IDIFFERENCE
(UNFOLD 2 WORDSPERPAGE)
(IPLUS 2 1
(FOLDHI
\SYSBUFFER.LAST
BYTESPERWORD)
1 NRINGINDEXWORDS))
EVENTLENGTH]
)
)
(DEFINEQ
(MACHINETYPE
[LAMBDA NIL (* lmm "30-MAR-83 20:43")
(SELECTQ (fetch MachineType of \InterfacePage)
(4 (QUOTE DOLPHIN))
(5 (QUOTE DORADO))
(6 (QUOTE DANDELION))
NIL])
(SETMAINTPANEL
[LAMBDA (N) (* bvm: " 8-JAN-83 18:21")
(SELECTC \MACHINETYPE
(\DANDELION (replace DLMAINTPANEL of \IOPAGE with N))
[\DOLPHIN ((OPCODES MISC1 3)
(\DTEST N (QUOTE SMALLP]
NIL])
)
(* DLion beeper)
(DEFINEQ
(BEEPON
[LAMBDA (FREQ) (* lmm " 3-AUG-82 10:35")
(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])
(BEEPOFF
[LAMBDA NIL (* lmm " 3-AUG-82 10:35")
(while (IGEQ (fetch DLBEEPCMD of \IOPAGE)
32768)
do (BLOCK))
(replace DLBEEPCMD of \IOPAGE with 32769)
NIL])
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR 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 \COLORCURSORBM \COLORCURSOR \COLORCURSORDOWN
\ColorCursorBBT \COLORCURSORWIDTH \COLORSCREENCURSORLINEBASE \COLORSCREENCURSORLINE
\COLORCURSORBASE \COLORSCREENWIDTHINBITS \COLORSCREENRASTERWIDTH \COLORCURSORRASTERWIDTH)
)
(* END EXPORTED DEFINITIONS)
(DEFINEQ
(WITHOUT-INTERRUPTS
[NLAMBDA (FORM) (* rrb "16-NOV-82 12:12")
(PROG (VAL)
[\PUTBASE \EM.DISPINTERRUPT 0 (PROG1 (\GETBASE \EM.DISPINTERRUPT 0)
(\PUTBASE \EM.DISPINTERRUPT 0 0)
(SETQ VAL (DISPLAYDOWN FORM]
(RETURN VAL])
)
(* Compile locked fns together for locality)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NIL \PUTSYSBUF \KEYHANDLER \KEYHANDLER1 \RESETKEYBOARD1 \DOTRANSITIONS \DOMOUSETRANSITIONS
\DECODETRANSITION KEYDOWNP1 \PERIODIC.INTERRUPTFRAME \CAUSE.PERIODIC.INTERRUPT \EVENTKEYS
\PUTEVENTQUEUE)
]
(DECLARE: DONTCOPY
(ADDTOVAR INEWCOMS (ALLOCAL (ADDVARS (LOCKEDFNS \KEYHANDLER \KEYHANDLER1 \RESETKEYBOARD1
\DOTRANSITIONS \DOMOUSETRANSITIONS \CONTEXTAPPLY
\LOCKPAGES \DECODETRANSITION \SMASHLINK
\PUTEVENTQUEUE \INCUSECOUNT \PUTSYSBUF CLOCK0
\EVENTKEYS KEYDOWNP1 LRSH LLSH \MAKEFREEBLOCK
\DECUSECOUNT \MAKENUMBER \ADDBASE
\PERIODIC.INTERRUPTFRAME \CAUSE.PERIODIC.INTERRUPT)
(LOCKEDVARS \InterfacePage \TRANSITIONFLAGS \SHIFTSTATE
\TRANSITIONSHIFTCODES \TRANSITIONCODES \EVENTSTATUS
\ARMEDINTERRUPTS \EVENTQUEUE \MOUSEHOTSPOTX
\MOUSEHOTSPOTY \MOUSETIMEBOX \SYSBUFFER
\PENDINGINTERRUPT \COLORCURSORBM \COLORCURSORDOWN
\COLORDISPLAYBITSPERPIXEL \ColorCursorBBT
\COLORCURSORWIDTH \COLORSCREENCURSORLINE
\COLORSCREENCURSORLINEBASE \COLORCURSORBASE
\COLORSCREENWIDTHINBITS \COLORSCREENRASTERWIDTH
\COLORCURSORRASTERWIDTH \PERIODIC.INTERRUPT
\PERIODIC.INTERRUPT.FREQUENCY \LASTUSERACTION
\MOUSECHORDTICKS)
(LOCKEDVARS \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.DISPLAYHEAD))))
(ADDTOVAR RDCOMS (FNS \SETIOPOINTERS))
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML WITHOUT-INTERRUPTS)
(ADDTOVAR LAMA METASHIFT MOUSECHORDWAIT)
)
(PUTPROPS LLKEY COPYRIGHT ("Xerox Corporation" 1982 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (7890 13536 (BKSYSCHARCODE 7900 . 8193) (\CLEARSYSBUF 8195 . 8631) (\GETKEY 8633 . 9511)
(\INTCHAR 9513 . 9864) (\NSYSBUFCHARS 9866 . 10422) (\SAVESYSBUF 10424 . 11531) (\SYSBUFP 11533 .
11817) (\GETSYSBUF 11819 . 11992) (\PUTSYSBUF 11994 . 12749) (\PEEKSYSBUF 12751 . 13534)) (14665 37161
(\KEYBOARDINIT 14675 . 16991) (\ALLOCLOCKED 16993 . 17429) (\SETIOPOINTERS 17431 . 20345) (
\KEYBOARDOFF 20347 . 20538) (\KEYBOARDON 20540 . 20732) (\KEYHANDLER 20734 . 20839) (\KEYHANDLER1
20841 . 29006) (\RESETKEYBOARD 29008 . 29552) (\RESETKEYBOARD1 29554 . 30269) (\DOMOUSETRANSITIONS
30271 . 33430) (\DOTRANSITIONS 33432 . 34047) (\DECODETRANSITION 34049 . 36789) (MOUSECHORDWAIT 36791
. 37159)) (46654 52242 (KEYACTION 46664 . 47033) (\KEYACTION1 47035 . 49627) (KEYDOWNP 49629 . 49850)
(KEYDOWNP1 49852 . 50549) (\KEYNAMETONUMBER 50551 . 51088) (MODIFY.KEYACTIONS 51090 . 51475) (
METASHIFT 51477 . 52240)) (52276 52825 (\KEYNAMETONUMBER 52286 . 52823)) (54160 57893 (
\SHOWCOLORCURSOR 54170 . 57891)) (58825 61307 (\INIT.KEYBOARD.STREAM 58835 . 59869) (
\KEYBOARD.GETEOFPTR 59871 . 60610) (\KEYBOARD.BACKFILEPTR 60612 . 61305)) (61570 62409 (
\PERIODIC.INTERRUPTFRAME 61580 . 61753) (\CAUSE.PERIODIC.INTERRUPT 61755 . 62407)) (62594 71487 (
ADJUSTCURSORPOSITION 62604 . 63048) (CREATEPOSITION 63050 . 63161) (CURSOR 63163 . 64096) (
CURSORCREATE 64098 . 64834) (CURSORHOTSPOT 64836 . 65334) (CURSORPOSITION 65336 . 66099) (
\SETCURSORPOSITION 66101 . 68700) (FLIPCURSOR 68702 . 68974) (LASTMOUSEX 68976 . 69296) (LASTMOUSEY
69298 . 69618) (POSITIONP 69620 . 69949) (SETCURSOR 69951 . 71485)) (71488 72872 (GETMOUSESTATE 71498
. 72150) (\EVENTKEYS 72152 . 72870)) (75336 81538 (BKMOUSEBUF 75346 . 76595) (CLEARMOUSEBUF 76597 .
77294) (ENABLEMOUSE 77296 . 78614) (GETMOUSEEVENT 78616 . 79837) (MOUSEBUF 79839 . 80023) (
\PUTEVENTQUEUE 80025 . 81324) (\ResetMouseQueue 81326 . 81536)) (84129 84657 (MACHINETYPE 84139 .
84370) (SETMAINTPANEL 84372 . 84655)) (84683 85299 (BEEPON 84693 . 85033) (BEEPOFF 85035 . 85297)) (
85864 86194 (WITHOUT-INTERRUPTS 85874 . 86192)))))
STOP