(FILECREATED " 8-Jan-84 16:58:15" {PHYLUM}<LISPCORE>SOURCES>LLKEY.;120 81426
changes to: (FNS \KEYHANDLER1)
previous date: "30-Dec-83 11:56:58" {PHYLUM}<LISPCORE>SOURCES>LLKEY.;118)
(* Copyright (c) 1982, 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT LLKEYCOMS)
(RPAQQ LLKEYCOMS [(FNS \ALLOCLOCKED)
(* Keyboard and mouse interpretation)
(FNS BKSYSCHARCODE \CLEARSYSBUF \GETKEY \INTCHAR \NSYSBUFCHARS \SAVESYSBUF \SYSBUFP
\GETSYSBUF \PUTSYSBUF \PEEKSYSBUF \ResetMouseQueue)
(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 (* Key handler)
(FNS \KEYBOARDINIT \KEYBOARDOFF \KEYBOARDON \KEYHANDLER \KEYHANDLER1 \RESETKEYBOARD
\RESETKEYBOARD1 \DOTRANSITIONS \DECODETRANSITION KEYACTION \KEYACTION1 KEYDOWNP
KEYDOWNP1 \KEYNAMETONUMBER MODIFY.KEYACTIONS METASHIFT)
(DECLARE: DONTCOPY (MACROS .NOTELASTUSERACTION)))
(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)))
(FNS \SHOWCOLORCURSOR)
(EXPORT (MACROS COLORNUMBERBITSPERPIXEL \BITADDRESSOFPIXEL .TAKE.DOWN.COLOR.CURSOR)
(CONSTANTS (COLORSCREENWIDTH 640)
(COLORSCREENHEIGHT 480)))
(DECLARE: EVAL@COMPILE DONTCOPY (FNS \KEYNAMETONUMBER))
(DECLARE: DONTEVAL@LOAD DOCOPY (P (\KEYBOARDINIT)))
(COMS (* Hook for a periodic interrupt)
(FNS \PERIODIC.INTERRUPTFRAME \CAUSE.PERIODIC.INTERRUPT)
(VARS (\PERIODIC.INTERRUPT))
(INITVARS (\PERIODIC.INTERRUPT.FREQUENCY 60)))
(LOCALVARS . T)
(EXPORT (MACROS KEYDOWNP KEYDOWNP1))
(DECLARE: DONTCOPY (E (RESETSAVE (RADIX 8)))
(CONSTANTS CURSORYMAX SCREENHEIGHT ALLUP)
(CONSTANTS \CTRLMASK \METABIT)
(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)
[COMS (* cursor and mouse related functions.)
(FNS ADJUSTCURSORPOSITION CREATEPOSITION CURSOR CURSORCREATE CURSORHOTSPOT
CURSORPOSITION FLIPCURSOR LASTMOUSEX LASTMOUSEY POSITIONP SETCURSOR)
[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)
(FNS BKMOUSEBUF CLEARMOUSEBUF ENABLEMOUSE GETMOUSEEVENT GETMOUSESTATE MOUSEBUF
\EVENTKEYS \PUTEVENTQUEUE \SETCURSORPOSITION)
(DECLARE: DONTCOPY (EXPORT (MACROS \SETMOUSEXY)))
(DECLARE: DONTEVAL@LOAD DOCOPY (VARS (\MouseEnabled)
(\MouseQueueAddrLo 51712)
(\MouseQueueOverhead 4)
(\SingleMouseEvent NIL)
(\MouseEventQueue)
(\ClearedMouseEvents)
(BUTTONCHARCODE)))
(DECLARE: DONTCOPY (RECORDS MOUSEQUEUE MOUSEPTR))
(GLOBALVARS \MouseQueueAddrLo \MouseEventQueue \MouseQueueOverhead \SingleMouseEvent
\MouseEnabled \DISPLAYREGION \ClearedMouseEvents)
(DECLARE: DOEVAL@COMPILE (VARS (SCREENHEIGHT 808)))
[DECLARE: DONTEVAL@LOAD DOCOPY (VARS (\SFPosition (CREATEPOSITION]
(DECLARE: DONTCOPY (CONSTANTS CURSORYMAX \MouseEventLength))
(DECLARE: DONTCOPY (RECORDS EVENTPTR EVENTSTATUS)
(CONSTANTS NO.EV CHAR.EV YES.EV))
(GLOBALVARS \MouseEnabled \ClearedMouseEvents)
(DECLARE: DONTCOPY (MACROS \XMOUSECOORD \YMOUSECOORD)
(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]
(INITVARS (\COLORCURSORBM)
(\COLORCURSORDOWN)
(\ColorCursorBBT)
(\COLORCURSOR))
(FNS \SETIOPOINTERS MACHINETYPE SETMAINTPANEL)
(COMS (* DLion beeper)
(FNS BEEPON BEEPOFF))
(EXPORT (GLOBALVARS \EM.MOUSEX \EM.MOUSEY \EM.CURSORX \EM.CURSORY \EM.UTILIN \EM.KBDAD0
\EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3 \EM.KBDAD4 \EM.KBDAD5 \EM.DISPINTERRUPT
\EM.CURSORBITMAP \SCREENDCB#SCANLINESADDR \MACHINETYPE \COLORCURSORBM
\COLORCURSOR \COLORCURSORDOWN \ColorCursorBBT \COLORCURSORWIDTH
\COLORSCREENCURSORLINEBASE \COLORSCREENCURSORLINE \COLORCURSORBASE
\COLORSCREENWIDTHINBITS \COLORSCREENRASTERWIDTH \COLORCURSORRASTERWIDTH))
(FNS WITHOUT-INTERRUPTS)
[DECLARE: DONTCOPY
(ADDVARS [INEWCOMS (ALLOCAL (ADDVARS (LOCKEDFNS \KEYHANDLER \KEYHANDLER1
\RESETKEYBOARD1 \DOTRANSITIONS
\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)
(LOCKEDVARS \EM.MOUSEX \EM.MOUSEY \EM.CURSORX
\EM.CURSORY \EM.UTILIN \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])
(DEFINEQ
(\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])
)
(* Keyboard and mouse interpretation)
(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])
(\ResetMouseQueue
[LAMBDA NIL (* lmm "18-APR-80 17:36")
(replace MouseQueueOUT of \MouseEventQueue with (fetch MouseQueueIN of \MouseEventQueue))
NIL])
)
(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))
)
(* 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])
(\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: " 8-Jan-84 16:57")
(PROG ((OLD0 ALLUP)
(OLD1 ALLUP)
(OLD2 ALLUP)
(OLD3 ALLUP)
(OLD4 ALLUP)
(OLD5 ALLUP)
(OLDU ALLUP)
(LOOPCNT 10)
(PERIODCNT 60)
SCRWIDTH CURSORX CURSORY YHOT)
(DECLARE (SPECVARS SCRWIDTH)
(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]
[OR (EQ OLDU (\GETBASE \EM.UTILIN 0))
(\DOTRANSITIONS 64 OLDU (SETQ OLDU (\GETBASE \EM.UTILIN 0]
[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: "29-APR-82 14:20")
(* 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))
(SETQ SCRWIDTH (UNFOLD (fetch (IFPAGE ScreenWidth) of \InterfacePage)
BITSPERWORD))
(replace (SHIFTSTATE SHIFTORLOCK) of \SHIFTSTATE with NIL)
(replace (SHIFTSTATE LOCK) of \SHIFTSTATE with (KEYDOWNP (QUOTE LOCK)))
(replace (SHIFTSTATE CTRL) of \SHIFTSTATE with NIL])
(\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])
(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: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS .NOTELASTUSERACTION MACRO (NIL (\BLT \LASTUSERACTION (LOCF (fetch SECONDSTMP of \MISCSTATS))
WORDSPERCELL)))
)
)
(* 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)
(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))])
)
(* 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)
(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])
)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(\KEYBOARDINIT)
)
(* 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) (* bvm: "11-NOV-82 15:09")
(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 (\MAKEFRAME (FUNCTION \PERIODIC.INTERRUPTFRAME)
NXT
(IPLUS NXT (fetch (FSB SIZE) of NXT))
FRAME FRAME))
(RETURN T])
)
(RPAQQ \PERIODIC.INTERRUPT NIL)
(RPAQ? \PERIODIC.INTERRUPT.FREQUENCY 60)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(* 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)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(RPAQQ CURSORYMAX 1430Q)
(RPAQQ SCREENHEIGHT 1450Q)
(RPAQQ ALLUP 177777Q)
(CONSTANTS CURSORYMAX SCREENHEIGHT ALLUP)
)
(DECLARE: EVAL@COMPILE
(RPAQQ \CTRLMASK 237Q)
(RPAQQ \METABIT 200Q)
(CONSTANTS \CTRLMASK \METABIT)
)
(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)
)
(* 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])
(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])
)
(* 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)
)
(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])
(GETMOUSESTATE
[LAMBDA NIL (* rrb "22-DEC-82 15:04"
) (* Reads the current
state of the mouse and
keyboard)
(SETQ LASTMOUSEX (\XMOUSECOORD))
(SETQ LASTMOUSEY (\YMOUSECOORD))
[SETQ LASTMOUSEBUTTONS (LOGOR (COND
((OR (KEYDOWNP (QUOTE CENTER))
(KEYDOWNP (QUOTE MIDDLE)))
1)
(T 0))
(COND
((KEYDOWNP (QUOTE RIGHT))
2)
(T 0))
(COND
((KEYDOWNP (QUOTE LEFT))
4)
(T 0]
(SETQ LASTMOUSETIME (fetch (FIXP LONUM) of (\CLOCK0 \MOUSETIMEBOX)))
(SETQ LASTKEYBOARD (\EVENTKEYS))
NIL])
(MOUSEBUF
[LAMBDA (FLG) (* returns the internal buffer of mouse events.)
(COND
(FLG \ClearedMouseEvents)
(T (SETQ \ClearedMouseEvents 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])
(\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])
(\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])
)
(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: 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: 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: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \MouseQueueAddrLo \MouseEventQueue \MouseQueueOverhead \SingleMouseEvent
\MouseEnabled \DISPLAYREGION \ClearedMouseEvents)
)
(DECLARE: DOEVAL@COMPILE
(RPAQQ SCREENHEIGHT 808)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQ \SFPosition (CREATEPOSITION))
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(RPAQQ CURSORYMAX 792)
(RPAQQ \MouseEventLength 5)
(CONSTANTS CURSORYMAX \MouseEventLength)
)
)
(DECLARE: DONTCOPY
[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: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \MouseEnabled \ClearedMouseEvents)
)
(DECLARE: DONTCOPY
(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: 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]
)
)
(RPAQ? \COLORCURSORBM )
(RPAQ? \COLORCURSORDOWN )
(RPAQ? \ColorCursorBBT )
(RPAQ? \COLORCURSOR )
(DEFINEQ
(\SETIOPOINTERS
[LAMBDA NIL (* bvm: "30-JUL-83 15:13")
(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.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))
(SETTOPVAL (QUOTE \EM.UTILIN)
(fetch DLUTILINPTR of \IOPAGE))
(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])
(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.KBDAD0 \EM.KBDAD1
\EM.KBDAD2 \EM.KBDAD3 \EM.KBDAD4 \EM.KBDAD5 \EM.DISPINTERRUPT \EM.CURSORBITMAP
\SCREENDCB#SCANLINESADDR \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])
)
(DECLARE: DONTCOPY
(ADDTOVAR INEWCOMS (ALLOCAL (ADDVARS (LOCKEDFNS \KEYHANDLER \KEYHANDLER1 \RESETKEYBOARD1
\DOTRANSITIONS \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)
(LOCKEDVARS \EM.MOUSEX \EM.MOUSEY \EM.CURSORX \EM.CURSORY
\EM.UTILIN \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)
)
(PUTPROPS LLKEY COPYRIGHT ("Xerox Corporation" 1982 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (7205 7653 (\ALLOCLOCKED 7215 . 7651)) (7700 13558 (BKSYSCHARCODE 7710 . 8003) (
\CLEARSYSBUF 8005 . 8441) (\GETKEY 8443 . 9321) (\INTCHAR 9323 . 9674) (\NSYSBUFCHARS 9676 . 10232) (
\SAVESYSBUF 10234 . 11341) (\SYSBUFP 11343 . 11627) (\GETSYSBUF 11629 . 11802) (\PUTSYSBUF 11804 .
12559) (\PEEKSYSBUF 12561 . 13344) (\ResetMouseQueue 13346 . 13556)) (14576 35067 (\KEYBOARDINIT 14586
. 16902) (\KEYBOARDOFF 16904 . 17095) (\KEYBOARDON 17097 . 17289) (\KEYHANDLER 17291 . 17396) (
\KEYHANDLER1 17398 . 24910) (\RESETKEYBOARD 24912 . 25456) (\RESETKEYBOARD1 25458 . 26128) (
\DOTRANSITIONS 26130 . 26745) (\DECODETRANSITION 26747 . 29487) (KEYACTION 29489 . 29858) (\KEYACTION1
29860 . 32452) (KEYDOWNP 32454 . 32675) (KEYDOWNP1 32677 . 33374) (\KEYNAMETONUMBER 33376 . 33913) (
MODIFY.KEYACTIONS 33915 . 34300) (METASHIFT 34302 . 35065)) (35301 37783 (\INIT.KEYBOARD.STREAM 35311
. 36345) (\KEYBOARD.GETEOFPTR 36347 . 37086) (\KEYBOARD.BACKFILEPTR 37088 . 37781)) (38004 41737 (
\SHOWCOLORCURSOR 38014 . 41735)) (42544 43093 (\KEYNAMETONUMBER 42554 . 43091)) (43188 44013 (
\PERIODIC.INTERRUPTFRAME 43198 . 43371) (\CAUSE.PERIODIC.INTERRUPT 43373 . 44011)) (53729 60021 (
ADJUSTCURSORPOSITION 53739 . 54183) (CREATEPOSITION 54185 . 54296) (CURSOR 54298 . 55231) (
CURSORCREATE 55233 . 55969) (CURSORHOTSPOT 55971 . 56469) (CURSORPOSITION 56471 . 57234) (FLIPCURSOR
57236 . 57508) (LASTMOUSEX 57510 . 57830) (LASTMOUSEY 57832 . 58152) (POSITIONP 58154 . 58483) (
SETCURSOR 58485 . 60019)) (60869 70865 (BKMOUSEBUF 60879 . 62128) (CLEARMOUSEBUF 62130 . 62827) (
ENABLEMOUSE 62829 . 64147) (GETMOUSEEVENT 64149 . 65370) (GETMOUSESTATE 65372 . 66055) (MOUSEBUF 66057
. 66241) (\EVENTKEYS 66243 . 66961) (\PUTEVENTQUEUE 66963 . 68262) (\SETCURSORPOSITION 68264 . 70863)
) (75359 78403 (\SETIOPOINTERS 75369 . 77883) (MACHINETYPE 77885 . 78116) (SETMAINTPANEL 78118 . 78401
)) (78429 79045 (BEEPON 78439 . 78779) (BEEPOFF 78781 . 79043)) (79604 79934 (WITHOUT-INTERRUPTS 79614
. 79932)))))
STOP