source: tags/system-46/lmio/kbd.lisp

Last change on this file was 234, checked in by rjs, 7 years ago

Initial versions.

File size: 20.1 KB
Line 
1; -*-LISP-*- MACHINE KNIGHT KEYBOARD HANDLER
2;       ** (c) Copyright 1980 Massachusetts Institute of Technology **
3
4;A lot of functions relating to KBD are in LISPM2;PROCES  notably KBD-PROCESS-TOP-LEVEL
5(SPECIAL %SYS-COM-REMOTE-KEYBOARD)              ;CHAR FROM PDP10 IN RAW FORM
6(SPECIAL TV-MORE-PROCESSING-GLOBAL-ENABLE)
7;(SPECIAL TV-CONTROL-REGISTER-2-ADDR TV-CONTROL-REGISTER-VIDEO-SWITCH)
8(SPECIAL KBD-LAST-ACTIVITY-TIME)
9
10(DEFVAR WHO-LINE-JUST-COLD-BOOTED-P NIL)        ;Use SET' not SETQ for cold-load benefit
11(ADD-INITIALIZATION "WHO-LINE-JUST-COLD-BOOTED-P" '(SET' WHO-LINE-JUST-COLD-BOOTED-P T)
12                    '(COLD))
13
14(SPECIAL KBD-TRANSLATE-TABLE KBD-SIMULATED-CLOCK-FCN-LIST INHIBIT-CLOCK-INTERRUPTS)
15
16;; If this is T, then it is KBD-INTERRUPT-PROCESS, rather than
17;; SELECTED-PROCESS, which is allowed to read input.
18(DEFVAR KBD-PROCESS-WANTS-INPUT-FLAG NIL)
19
20;; KBD-TYI calls this function on each character.
21;; It is for handling "synchronous interrupt characters"
22;; that do something when read that has nothing to do with just who is reading them.
23;; The argument is the character.  The value can be the same character,
24;; a translated character to return from KBD-TYI instead,
25;; or NIL to make KBD-TYI ignore this character and read another.
26;; The default one handles C-Z with a THROW to SI:TOP-LEVEL and BREAK with a breakpoint.
27(DEFVAR KBD-TYI-HOOK 'DEFAULT-KBD-TYI-HOOK)
28
29(DEFUN KBD-SUPER-IMAGE-P ()
30    (AND SELECTED-PROCESS
31         (GET (LOCF (PROCESS-PLIST SELECTED-PROCESS)) ':KBD-SUPER-IMAGE-P)))
32
33;KEYBOARD INTERFACE HARDWARE DOCUMENTATION
34;764100 READS THE KEYBOARD DATA, LOW 16 BITS
35;764102 READS THE KEYBOARD DATA, HIGH 16 BITS
36;764104, 764106 ARE THE MOUSE
37;764110 - REFERENCING THIS COMPLEMENTS THE BEEPER OUTPUT
38;764112 IS THE STATUS REGISTER FOR KEYBOARD, MOUSE, AND CLOCK
39;  0 REMOTE MOUSE ENABLE
40;  1-3 INTERRUPT ENABLES
41;  4 MOUSE READY
42;  5 KEYBOARD READY
43;  6 CLOCK READY
44;FORMAT OF DATA IN 764100 (IF USING OLD KEYBOARD):
45; 00077   0006    ;KEY CODE
46; 00300   0602    ;SHIFT LEFT,RIGHT
47; 01400   1002    ;TOP LEFT,RIGHT
48; 06000   1202    ;CONTROL LEFT,RIGHT
49; 30000   1402    ;META LEFT,RIGHT
50; 40000   1601    ;SHIFT LOCK
51
52;In the latest CADR version, the microcode takes interrupts and
53;stores keyboard characters into a ring-buffer stored in locations
54;500-577 inclusive.  See the file LMIO; UNIBUS for more documentation on these buffers.
55
56(ENDF HEAD)
57
58;; This is here rather than with the scheduler because it has to be
59;; in the cold-load.  It checks for the non-existence of a scheduler
60;; and does it itself in that case.
61
62;; Takes a predicate and arguments to it.  The process becomes blocked
63;; until the application of the predicate to those arguments returns T.
64;; Note that the function is run in the SCHEDULER stack group, not the
65;; process's stack group!  This means that bindings in effect at the
66;; time PROCESS-WAIT is called will not be in effect; don't refer to
67;; variables "freely" if you are binding them.
68;;    Kludge:  if the scheduler seems broken, or we ARE the scheduler
69;; (i.e. a clock function tries to block), then loop-wait (no blinkers...)
70
71;; In case of a sequence-break while waiting, this function can get "reinvoked".
72;; Therefore, it must not modify its arguments, and must observe other restrictions.
73;; see EH-REINVOKE.
74(DEFUN PROCESS-WAIT (WHOSTATE FUNCTION &REST ARGUMENTS)
75  (COND ((APPLY FUNCTION ARGUMENTS)     ;Test condition before doing slow stack-group switch
76         NIL)                           ;Hmm, no need to wait after all
77        ((OR (NOT SCHEDULER-EXISTS)
78             (EQ SCHEDULER-STACK-GROUP %CURRENT-STACK-GROUP)
79             (NULL CURRENT-PROCESS)
80             (LET ((STATE (SG-CURRENT-STATE SCHEDULER-STACK-GROUP)))
81               (NOT (OR (= STATE SG-STATE-AWAITING-INITIAL-CALL)
82                        (= STATE SG-STATE-AWAITING-RETURN)))))
83         (DO () (NIL)
84           (AND (APPLY FUNCTION ARGUMENTS)
85                (RETURN NIL))))
86        (T
87         (SETF (PROCESS-WHOSTATE CURRENT-PROCESS) WHOSTATE)
88         (AND (EQ CURRENT-PROCESS TV-WHO-LINE-PROCESS)
89              (TV-WHO-LINE-RUN-STATE-UPDATE))           ;Mark who-line as waiting
90         (WITHOUT-INTERRUPTS    ;Dont allow below frobs to get reset by SB
91           (SET-PROCESS-WAIT CURRENT-PROCESS FUNCTION ARGUMENTS)
92           (FUNCALL SCHEDULER-STACK-GROUP))
93         (COND ((EQ CURRENT-PROCESS TV-WHO-LINE-PROCESS) ;Mark who-line as running
94                (TV-WHO-LINE-RUN-STATE-UPDATE))))))
95
96
97;; Read one character from the keyboard, processing BREAK and C-Z
98;; (or whatever else the function which is the value of KBD-TYI-HOOK implements)
99;; The optional argument is the wholine state string.
100;; KBD-TYI-HOOK is funcalled with each character.
101;; It can return the character, a different character to return instead,
102;; or NIL to ignore the character aside from what the hook function already did.
103(DEFUN KBD-TYI (&OPTIONAL (WHOSTATE "TYI"))
104  (PROG (CH)
105TOP (SETQ CH (KBD-TYI-1 WHOSTATE))          ;Get a character.
106    (SETQ CH (FUNCALL KBD-TYI-HOOK CH))
107    (COND ((NULL CH) (GO TOP))
108          ((LISTP CH) (GO TOP))             ;Ignore mouse characters.
109          (T (RETURN CH)))))
110
111;; This is the default hook function for KBD-TYI.
112;; We call BREAK if BREAK is typed, and throw to TOP-LEVEL is C-Z is typed.
113;; Anything else we allow to be returned by KBD-TYI.
114(DEFUN DEFAULT-KBD-TYI-HOOK (CH)
115  (COND ((LISTP CH) CH)
116        ((= CH #\BREAK) (BREAK BREAK T) NIL)
117        ((OR (= CH #/Z) (= CH #/z))   ;Don't call CHAR-UPCASE, not defined in cold-load
118         (PRINC "Z Quit")
119         (THROW NIL TOP-LEVEL))
120        (T CH)))
121
122;; Return a character read from the keyboard.
123(DEFUN KBD-TYI-1 (&OPTIONAL (WHOSTATE "TYI") &AUX TEM)
124  (DO () (NIL) ;forever.
125    (COND ((SETQ TEM (KBD-TYI-NO-HANG))
126           (SETQ KBD-LAST-ACTIVITY-TIME (TIME) WHO-LINE-JUST-COLD-BOOTED-P NIL)
127           (AND TEM (RETURN TEM))))
128    (TV-NOTE-INPUT) ;Have hung waiting for user
129    (PROCESS-WAIT WHOSTATE
130                  (FUNCTION KBD-CHAR-AVAILABLE))))
131
132;; Input a character in Lisp-machine ascii code.  NIL if none immediately available.
133(DEFUN KBD-TYI-NO-HANG (&AUX KBD ASC PROCESS (INHIBIT-SCHEDULING-FLAG T))
134  (COND ((NOT (KBD-CHAR-AVAILABLE)) NIL)  ;Nothing available, return NIL
135        ;; Check for forced input associated with this process.
136        ((AND CURRENT-PROCESS
137              (SETQ KBD (PROCESS-FORCED-INPUT CURRENT-PROCESS)))
138         (SETQ PROCESS CURRENT-PROCESS)
139         (COND ((OR (NUMBERP KBD) (LISTP KBD))
140                (SETF (PROCESS-FORCED-INPUT PROCESS) NIL)
141                KBD)
142               ((ARRAYP KBD)
143                (PROG1 (AR-1 KBD (SETQ ASC (PROCESS-FORCED-INPUT-INDEX PROCESS)))
144                       (SETF (PROCESS-FORCED-INPUT-INDEX PROCESS) (SETQ ASC (1+ ASC)))
145                       (OR (< ASC (ARRAY-ACTIVE-LENGTH KBD))
146                           (SETF (PROCESS-FORCED-INPUT PROCESS) NIL))))
147               (T
148                (SETF (PROCESS-FORCED-INPUT PROCESS) NIL)  ;In hopes of not bombing on next TYI.
149                (FERROR NIL "~S is invalid PROCESS-FORCED-INPUT" KBD))))
150        ;; Check for input over the remote keyboard link
151        ((PLUSP (SETQ KBD (SYSTEM-COMMUNICATION-AREA %SYS-COM-REMOTE-KEYBOARD)))
152         (STORE (SYSTEM-COMMUNICATION-AREA %SYS-COM-REMOTE-KEYBOARD) -1)
153         KBD)
154        ;; Check for hardware input, this will have to be code-converted
155        (KBD-BUFFER           ;Put here by SI:KBD-GET-HARDWARE-CHAR-IF-ANY
156         (SETQ KBD KBD-BUFFER
157               KBD-BUFFER NIL)
158         (KBD-CONVERT KBD))))
159
160;Convert a character as read from the keyboard hardware
161;to one in the standard Lisp machine character set.
162(DEFUN KBD-CONVERT (KBD &AUX ASC SHIFT BUCKY)
163  (COND ((= (LDB 2003 KBD) 1) ;Check source ID for new keyboard
164         (KBD-CONVERT-NEW KBD))
165        (T
166         (SETQ SHIFT (COND ((BIT-TEST 1400 KBD) 2)      ;TOP
167                           ((BIT-TEST 300 KBD) 1)       ;SHIFT
168                           (T 0)))                      ;VANILLA
169         (SETQ BUCKY (+ (COND ((BIT-TEST 06000 KBD) 0400) (T 0))        ;CONTROL
170                        (COND ((BIT-TEST 30000 KBD) 1000) (T 0))))      ;META
171         (SETQ ASC (AR-2 KBD-TRANSLATE-TABLE SHIFT (LOGAND 77 KBD)))
172         (AND (BIT-TEST 40000 KBD)                      ;SHIFT LOCK
173              (NOT (< ASC 141))
174              (NOT (> ASC 172))
175              (SETQ ASC (- ASC 40)))
176         (+ ASC BUCKY))))
177
178;; This function is for those who like to eat it raw.  It is identical to
179;; KBD-TYI-NO-HANG except that it gives you raw hardware code and consequently
180;; only works for input coming from the hardware.
181(DEFUN KBD-TYI-RAW-NO-HANG (&AUX (INHIBIT-SCHEDULING-FLAG T))
182  (COND ((NOT (KBD-CHAR-AVAILABLE)) NIL)  ;Nothing available, return NIL
183        ;; Check for processed (unhealthy) input
184        ((OR (AND CURRENT-PROCESS
185                  (PROCESS-FORCED-INPUT CURRENT-PROCESS))
186             (PLUSP (SYSTEM-COMMUNICATION-AREA %SYS-COM-REMOTE-KEYBOARD)))
187         (FERROR NIL "Attempt to read raw keyboard code from non-hardware source"))
188        ;; Return raw code from KBD-BUFFER
189        (T (PROG1 KBD-BUFFER
190                  (SETQ KBD-BUFFER NIL)))))
191
192;; This function decides whether a character is available to this process.
193;; If so, it returns T, if not it returns NIL.  This is suitable
194;; for use as a process-wait function.
195;; Importantly, this function simulates interrupts by checking
196;; for special characters and signalling the keyboard process.
197;; The 3 sources of characters are the hardware, the remote keyboard,
198;; and job-forced-input, which cannot supply special characters.
199;; The hardware is the only one which needs to be code-converted.
200;; This function is the only one which reads anything out of the hardware,
201;; moving it into the variable KBD-BUFFER.  Later, some of this function
202;; will be in the microcoded keyboard interrupt handler.
203;; JUST-INTERRUPTS means only check for interrupts.
204(DEFUN KBD-CHAR-AVAILABLE (&OPTIONAL JUST-INTERRUPTS)
205 (WITHOUT-INTERRUPTS
206  (PROG (CH CH6)
207   TRY-AGAIN
208    ;; Get hardware input if any
209    (AND (NULL KBD-BUFFER)
210         (KBD-GET-HARDWARE-CHAR-IF-ANY))
211    ;; Bypass interrupt check if interrupts not to be taken now
212    (AND (KBD-SUPER-IMAGE-P) (GO NOINT))
213    (AND (NOT JUST-INTERRUPTS)
214         (OR (NULL CURRENT-PROCESS)
215             (EQ CURRENT-PROCESS KBD-INTERRUPT-PROCESS))
216         (GO NOINT))
217    ;; Check hardware input for interrupt
218    (COND ((NULL KBD-BUFFER))                   ;No character
219          ((= (LDB 2003 KBD-BUFFER) 7)          ;Old keyboard
220           (AND (OR (= (SETQ CH6 (LOGAND KBD-BUFFER 77)) 1)  ;ESC in raw code
221                    (= CH6 20))                 ;CALL in raw code
222                (GO INT)))
223          ((= (LDB 2003 KBD-BUFFER) 1)          ;New keyboard
224           (AND (OR (= (SETQ CH6 (LDB 0020 KBD-BUFFER)) 107)    ;CALL
225                    (= CH6 40))                 ;ESC (terminal escape)
226                (GO INT))
227           (COND ((BIT-TEST 100400 KBD-BUFFER)  ;Do unreal characters
228                  (KBD-CONVERT-NEW KBD-BUFFER)
229                  (SETQ KBD-BUFFER NIL)
230                  (GO TRY-AGAIN)))))
231    ;; Check remote input for interrupt
232    (AND (PLUSP (SETQ CH (SYSTEM-COMMUNICATION-AREA %SYS-COM-REMOTE-KEYBOARD)))
233         (OR (= (SETQ CH6 (LDB %%KBD-CHAR CH)) 204)     ;ESC
234             (= CH6 203))                       ;CALL
235         (GO INT))
236   NOINT
237    ;; No interrupt to be taken, check for input
238    (AND JUST-INTERRUPTS (RETURN NIL))
239    (RETURN (COND ((AND CURRENT-PROCESS (PROCESS-FORCED-INPUT CURRENT-PROCESS)))  ;Forced input
240                  ((AND CURRENT-PROCESS
241                        (NEQ CURRENT-PROCESS
242                             (OR (AND KBD-PROCESS-WANTS-INPUT-FLAG KBD-INTERRUPT-PROCESS)
243                                 SELECTED-PROCESS)))
244                   NIL) ;This process not allowed to look at kbd
245                  (KBD-BUFFER)
246                  ((PLUSP (SYSTEM-COMMUNICATION-AREA %SYS-COM-REMOTE-KEYBOARD)))
247                  (T NIL)))
248   INT
249    ;; Take interrupt
250    (SETQ KBD-INTERRUPT-KLUDGE T)
251    (RETURN NIL))))
252
253;;; Sys com locations 500-577 are reserved for the wired keyboard buffer:
254;;; Locations 501 through 511 contain the buffer header; 520-577 are the buffer (48. chars)
255
256;; Refresh KBD-BUFFER if hardware has a character
257;; Call this only from KBD-CHAR-AVAILABLE with INTERRUPTS OFF.
258(DEFUN KBD-GET-HARDWARE-CHAR-IF-ANY (&AUX P)
259  (COND (( (%P-LDB %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-BUFFER-IN-PTR))
260            (SETQ P (%P-LDB %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-BUFFER-OUT-PTR))))
261         (SETQ KBD-BUFFER (%P-LDB %%Q-POINTER P))
262         (SETQ P (1+ P))
263         (AND (= P (%P-LDB %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-BUFFER-END)))
264              (SETQ P (%P-LDB %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-BUFFER-START))))
265         (%P-DPB P %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-BUFFER-OUT-PTR)))))
266
267;; Translate from a Unibus address to a Lisp machine virtual address, returning a fixnum.
268(DEFUN VIRTUAL-UNIBUS-ADDRESS (ADR)
269  (%24-BIT-PLUS (LSH 7740 12.) (LSH ADR -1)))
270
271;; This is called when the machine is booted, warm or cold.  It's not an
272;; initialization because it has to happen before all other initializations.
273(DEFUN INITIALIZE-WIRED-KBD-BUFFER ()
274  (DO I 500 (1+ I) (= I 600)
275    (%P-STORE-TAG-AND-POINTER I 0 0))
276  (%P-DPB 260 %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-VECTOR-ADDRESS))
277  (%P-DPB (VIRTUAL-UNIBUS-ADDRESS 764112) %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-CSR-ADDRESS))
278  (%P-DPB 40 %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-CSR-BITS))
279  (%P-DPB (VIRTUAL-UNIBUS-ADDRESS 764100) %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-DATA-ADDRESS))
280  (%P-DPB 1 %%Q-FLAG-BIT (+ 500 %UNIBUS-CHANNEL-DATA-ADDRESS))
281  (%P-DPB 520 %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-BUFFER-START))
282  (%P-DPB 600 %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-BUFFER-END))
283  (%P-DPB 520 %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-BUFFER-IN-PTR))
284  (%P-DPB 520 %%Q-POINTER (+ 500 %UNIBUS-CHANNEL-BUFFER-OUT-PTR))
285  (STORE (SYSTEM-COMMUNICATION-AREA %SYS-COM-UNIBUS-INTERRUPT-LIST) 500)
286  (%UNIBUS-WRITE 764112 4))     ;Keyboard interrupt enable, local mouse
287
288;KEYBOARD TRANSLATE TABLE IS A 3 X 64 ARRAY.
289;3 ENTRIES FOR EACH OF 100 KEYS.  FIRST IS VANILLA, SECOND SHIFT, THIRD TOP.
290;THE FUNCTION KBD-INITIALIZE IS ONLY CALLED ONCE, IN ORDER TO SET UP THIS ARRAY.
291
292(DEFUN KBD-INITIALIZE ()
293  (SETQ TV-WHO-LINE-RUN-LIGHT-LOC 51765
294        USER-ID "")
295  (SETQ KBD-TRANSLATE-TABLE (MAKE-ARRAY WORKING-STORAGE-AREA 'ART-8B '(3 100)))
296  (DO ((I 0 (1+ I))  ;2ND DIMENSION
297       (L '(
298        201     201     201             ;0 BREAK
299        204     204     204             ;1 ESCAPE
300        61      41      41              ;2 ONE
301        62      42      42              ;3 TWO
302        63      43      43              ;4 THREE
303        64      44      44              ;5 FOUR
304        65      45      45              ;6 FIVE
305        66      46      46              ;7 SIX
306        67      47      47              ;10 SEVEN
307        70      50      50              ;11 EIGHT
308        71      51      51              ;12 NINE
309        60      137     137             ;13 ZERO
310        55      75      75              ;14 EQUAL
311        100     140     140             ;15 ATSIGN
312        136     176     176             ;16 TILDE
313        210     210     210             ;17 BS
314        203     203     203             ;20 CALL
315        202     202     202             ;21 CLEAR
316        211     211     211             ;22 TAB
317        33      33      33              ;23 ALTMODE
318        161     121     4               ;24 CONJUNCTION
319        167     127     37              ;25 DISJUNCTION
320        145     105     22              ;26 UPLUMP
321        162     122     23              ;27 DOWNLUMP
322        164     124     20              ;30 LEFTLUMP
323        171     131     21              ;31 RIGHTLUMP
324        165     125     5               ;32 ELBOW
325        151     111     26              ;33 WHEEL
326        157     117     1               ;34 DOWNARROW
327        160     120     13              ;35 UPARROW
328        133     173     173             ;36 LEFT BRACKET
329        135     175     175             ;37 RIGHT BRACE
330        134     174     174             ;40 VERTICAL BAR
331        57      16      16              ;41 INFINITY
332        14      12      0               ;42 PLUS MINUS / DELTA (WRONG KEYTOP)
333        15      11      177             ;43 CIRCLE PLUS / GAMMA (WRONG KEYTOP)
334        214     214     214             ;44 FORM
335        213     213     213             ;45 VT
336        207     207     207             ;46 RUBOUT
337        141     101     34              ;47 LESS OR EQUAL
338        163     123     35              ;50 GREATER OR EQUAL
339        144     104     36              ;51 EQUIVALENCE
340        146     106     17              ;52 PARTIAL
341        147     107     32              ;53 NOT EQUAL
342        150     110     206             ;54 HELP
343        152     112     30              ;55 LEFTARROW
344        153     113     31              ;56 RIGHTARROW
345        154     114     27              ;57 BOTHARROW
346        73      53      53              ;60 PLUS
347        72      52      52              ;61 STAR
348        215     215     215             ;62 RETURN
349        212     212     212             ;63 LINE
350        205     205     205             ;64 BACKNEXT
351        172     132     2               ;65 ALPHA
352        170     130     3               ;66 BETA
353        143     103     6               ;67 EPSILON
354        166     126     10              ;70 LAMBDA
355        142     102     7               ;71 PI
356        156     116     24              ;72 UNIVERSAL
357        155     115     25              ;73 EXISTENTIAL
358        54      74      74              ;74 LESS THAN
359        56      76      76              ;75 GREATER THAN
360        57      77      77              ;76 QUESTION MARK
361        40      40      40              ;77 HORIZONTAL BAR
362        ) (CDDDR L)))
363      ((NULL L))
364    (AS-2 (CAR L) KBD-TRANSLATE-TABLE 0 I)
365    (AS-2 (CADR L) KBD-TRANSLATE-TABLE 1 I)
366    (AS-2 (CADDR L) KBD-TRANSLATE-TABLE 2 I)))
367
368;Support for new keyboard
369
370(DEFVAR KBD-SHIFTS 0)                   ;Bit mask of shifting keys held down
371
372(DECLARE (SPECIAL KBD-NEW-TABLE))       ;Array used as translation table.
373;The second dimension is 200 long and indexed by keycode.
374;The first dimension is the shifts:
375; 0 unshifted
376; 1 shift
377; 2 caps lock and no shift
378; 3 top
379; 4 greek
380; 5 shift greek
381;Elements in the table are 16-bit unsigned numbers.
382;Bit 15 on and bit 14 on means undefined code, ignore and beep.
383;Bit 15 on and bit 14 off means low bits are shift for bit in KBD-SHIFTS
384;Bit 15 off is ordinary code.
385
386;Can return NIL if character wasn't really a character.
387(DEFUN KBD-CONVERT-NEW (CH)
388  (COND ((BIT-TEST 1_15. CH)            ;An all-keys-up code, just update shifts mask
389         (SETQ KBD-SHIFTS (LDB 0012 CH))
390         NIL)
391        (T (LET ((NCH (AREF KBD-NEW-TABLE       ;NCH gets translate-table entry
392                            (COND ((BIT-TEST 2 KBD-SHIFTS)      ;Greek
393                                   (+ (LOGAND 1 KBD-SHIFTS) 4))
394                                  ((BIT-TEST 4 KBD-SHIFTS) 3)   ;Top
395                                  ((BIT-TEST 1 KBD-SHIFTS) 1)   ;Shift
396                                  ((BIT-TEST 10 KBD-SHIFTS) 2)  ;Caps lock
397                                  (T 0))
398                            (LDB 0007 CH))))
399             (COND ((BIT-TEST 1_15. NCH)        ;Not a real character
400                    (COND ((BIT-TEST 1_14. NCH) ;Undefined key, beep if key-down
401                           (OR (BIT-TEST 1_8 CH)
402                               (TV-BEEP)))
403                          (T                    ;A shifting key, update KBD-SHIFTS
404                            (SETQ KBD-SHIFTS (BOOLE (IF (BIT-TEST 1_8 CH) 2 7)
405                                                    (LSH 1 (LOGAND NCH 77))
406                                                    KBD-SHIFTS))))
407                    NIL)
408                   ((BIT-TEST 1_8 CH) NIL)       ;Just an up-code
409                   (T (DPB (LDB 0402 KBD-SHIFTS) ;Control and Meta
410                           1002 NCH)))))))       ;A real character pushed down
411
412(DEFUN KBD-MAKE-NEW-TABLE ()
413  (SETQ TV-BEEP NIL)                    ;Temporary, kbd has no beeper
414  (LET ((TBL (MAKE-ARRAY PERMANENT-STORAGE-AREA 'ART-16B '(6 200))))
415    (DO ((J 0 (1+ J))
416         (L '(
417        ()                                       ;0 not used
418        ()                                       ;1 Roman II
419        ()                                       ;2 Roman IV
420        100011                                   ;3 Mode lock
421        ()                                       ;4 not used
422        100006                                   ;5 Left super
423        ()                                       ;6 not used
424        ()                                       ;7 not used
425        ()                                       ;10 not used
426        (#/4 #/$ #/4 #/$)                        ;11 Four
427        (#/r #/R #/R #/)                        ;12 R
428        (#/f #/F #/F)                            ;13 F
429        (#/v #/V #/V)                            ;14 V
430        100008                                   ;15 Alt Lock
431        ()                                       ;16 not used
432        ()                                       ;17 Hand Right
433        100004                                   ;20 Left control
434        (#/: 14 #/: 14)                          ;21 plus-minus
435        #\TAB                                    ;22 tab
436        #\RUBOUT                                 ;23 rubout
437        100000                                   ;24 Left Shift
438        100000                                   ;25 Right Shift
439        100004                                   ;26 Right control
440        ()                                       ;27 not used
441        ()                                       ;30 hold output
442        (#/8 #/* #/8 #/*)                        ;31 Eight
443        (#/i #/I #/I #/)                        ;32 I
444        (#/k #/K #/K #/)                        ;33 K
445        (#/, #/< #/, #/<)                        ;34 comma
446        100001                                   ;35 Right Greek
447        #\LINE                                   ;36 Line
448        (#/\ #/| #/\ #/|)                        ;37 Backslash
449        #\ESC                                    ;40 terminal
450        ()                                       ;41 not used
451        ()                                       ;42 network
452        ()                                       ;43 not used
453        100001                                   ;44 Left Greek
454        100005                                   ;45 Left Meta
455        ()                                       ;46 status
456        ()                                       ;47 resume
457        #\FORM                                   ;50 clear screen
458        (#/6 #/^ #/6 #/^)                        ;51 Six
459        (#/y #/Y #/Y #/)                        ;52 Y
460        (#/h #/H #/H #/)                        ;53 H
461        (#/n #/N #/N #/)                        ;54 N
462        ()                                       ;55 not used
463        ()                                       ;56 not used
464        ()                                       ;57 not used
465        ()                                       ;60 not used
466        (#/2 #/@ #/2 #/@)                        ;61 Two
467        (#/w #/W #/W #/)                        ;62 W
468        (#/s #/S #/S)                            ;63 S
469        (#/x #/X #/X)                            ;64 X
470        100006                                   ;65 Right Super
471        ()                                       ;66 not used
472        ()                                       ;67 Abort
473        ()                                       ;70 not used
474        (#/9 #/( #/9 #/( )                       ;71 Nine
475        (#/o #/O #/O #/)                        ;72 O
476        (#/l #/L #/L #/ 10)                     ;73 L/lambda
477        (#/. #/> #/. #/>)                        ;74 period
478        ()                                       ;75 not used
479        ()                                       ;76 not used
480        (#/` #/~ #/` #/~ #/)                    ;77 back quote
481        #\BACK-NEXT                              ;100 macro
482        ()                                       ;101 Roman I
483        ()                                       ;102 Roman III
484        ()                                       ;103 not used
485        100002                                   ;104 Left Top
486        ()                                       ;105 not used
487        ()                                       ;106 Up Thumb
488        #\CALL                                   ;107 Call
489        #\CLEAR                                  ;110 Clear Input
490        (#/5 #/% #/5 #/%)                        ;111 Five
491        (#/t #/T #/T #/)                        ;112 T
492        (#/g #/G #/G #/ 11)                     ;113 G/gamma
493        (#/b #/B #/B #/ #/)                    ;114 B
494        ()                                       ;115 Repeat
495        #\HELP                                   ;116 Help
496        ()                                       ;117 Hand Left
497        ()                                       ;120 Quote
498        (#/1 #/! #/1 #/!)                        ;121 One
499        (#/q #/Q #/Q #/)                        ;122 Q
500        (#/a #/A #/A 140000 #/)                 ;123 A
501        (#/z #/Z #/Z)                            ;124 Z
502        100003                                   ;125 Caps Lock
503        (#/= #/+ #/= #/+)                        ;126 Equals
504        ()                                       ;127 not used
505        ()                                       ;130 not used
506        (#/- #/_ #/- #/_)                        ;131 Minus
507        (#/( #/[ #/( #/[)                        ;132 Open parenthesis
508        (#/' #/" #/' #/" 0)                      ;133 Apostrophe/center-dot
509        #\SP                                     ;134 Space
510        ()                                       ;135 not used
511        #\CR                                     ;136 Return
512        (#/) #/] #/) #/])                        ;137 Close parenthesis
513        ()                                       ;140 not used
514        ()                                       ;141 system
515        ()                                       ;142 not used
516        #/                                      ;143 Alt Mode
517        ()                                       ;144 not used
518        100007                                   ;145 Left Hyper
519        (#/} 140000 #/} 140000)                  ;146 }
520        ()                                       ;147 not used
521        ()                                       ;150 not used
522        (#/7 #/& #/7 #/&)                        ;151 Seven
523        (#/u #/U #/U #/)                        ;152 U
524        (#/j #/J #/J #/)                        ;153 J
525        (#/m #/M #/M #/)                        ;154 M
526        100002                                   ;155 Right Top
527        ()                                       ;156 End
528        ()                                       ;157 Delete
529        ()                                       ;160 Overstrike
530        (#/3 #/# #/3 #/#)                        ;161 Three
531        (#/e #/E #/E #/ #/)                    ;162 E
532        (#/d #/D #/D 140000 15)                  ;163 D/delta
533        (#/c #/C #/C #/)                        ;164 C
534        100005                                   ;165 Right Meta
535        (#/{ 140000 #/{ 140000)                  ;166 {
536        #\BREAK                                  ;167 Break
537        ()                                       ;170 Stop Output
538        (#/0 #/) #/0 #/))                        ;171 Zero
539        (#/p #/P #/P #/ #/)                    ;172 P
540        (#/; #/: #/; #/:)                        ;173 Semicolon
541        (#// #/? #// #/? 177)                    ;174 Question/Integral
542        100007                                   ;175 Right Hyper
543        ()                                       ;176 Down Thumb
544        ()                                       ;177 Not used
545              ) (CDR L)))
546        ((= J 200) (SETQ KBD-NEW-TABLE TBL))
547      (DO ((I 0 (1+ I))
548           (K (CAR L)))
549          ((= I 6))
550        (ASET (COND ((ATOM K) (OR K 140000))
551                    ((NULL (CAR K)) 140000)
552                    (T (CAR K)))
553              TBL I J)
554        (AND (LISTP K) (SETQ K (CDR K)))))))
555
556(SETQ KBD-NEW-TABLE (KBD-MAKE-NEW-TABLE))
Note: See TracBrowser for help on using the repository browser.