root/trunk/lisp/nzwei/kbdmac.lisp @ 258

Revision 258, 13.7 KB (checked in by rjs, 21 months ago)

Update.
Line 
1;;; ZWEI keyboard macros -*-MODE:LISP;PACKAGE:ZWEI-*-
2;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **
3
4(DEFVAR MACRO-ESCAPE-CHAR #\BACK-NEXT)
5(DEFVAR MACRO-STREAM)
6(DEFVAR MACRO-LEVEL)
7(DEFVAR MACRO-UNTYI)
8(DEFVAR MACRO-LEVEL-ARRAY)
9(DEFVAR MACRO-CURRENT-ARRAY)
10(DEFVAR MACRO-PREVIOUS-ARRAY)
11(DEFVAR MACRO-READING NIL)
12(DEFVAR MACRO-REDIS-LEVEL -1)
13(DEFVAR MACRO-OPERATIONS)
14
15(DEFSTRUCT (MACRO-ARRAY ARRAY-LEADER (MAKE-ARRAY (NIL 'ART-Q 100)))
16           (MACRO-POSITION 0)           ;Current position reading or writing
17           (MACRO-LENGTH 0)             ;Length of macro
18           MACRO-COUNT                  ;Current repeat count for macro
19           MACRO-DEFAULT-COUNT          ;Initial value of MACRO-COUNT, or NIL if writing
20           MACRO-NAME)                  ;Name of macro as a string, or NIL if temporary.
21
22;;; The following structure is used for the Backnext-A command.
23;;; It is important that it be a LIST since that is how it is
24;;; identified.
25(DEFSTRUCT (MACRO-A LIST)
26           (MACRO-A-NAME '*A*)          ;Symbol by which this is recognized.
27           MACRO-A-VALUE                ;Current value of the character.
28           MACRO-A-STEP                 ;Number to increase VALUE by on each step.
29           MACRO-A-INITIAL-VALUE)       ;Initial current-value given by user.
30
31(DEFUN MAKE-MACRO-STREAM (STREAM)
32  (LET-CLOSED ((MACRO-STREAM STREAM)
33               (MACRO-LEVEL -1)
34               (MACRO-UNTYI NIL)
35               (MACRO-LEVEL-ARRAY (MAKE-ARRAY NIL 'ART-Q 20))
36               (MACRO-CURRENT-ARRAY NIL)
37               (MACRO-PREVIOUS-ARRAY NIL)
38               (MACRO-OPERATIONS
39                 (LET ((OPS (APPEND (FUNCALL STREAM ':WHICH-OPERATIONS) NIL)))
40                   (MAPC #'(LAMBDA (X) (SETQ OPS (DELQ X OPS)))
41                         '(:TYI :UNTYI :LISTEN :CLEAR-INPUT :MACRO-LEVEL :MACRO-ERROR
42                           :MACRO-EXECUTE :LINE-IN :RUBOUT-HANDLER))
43                   `(:TYI :UNTYI :LISTEN :CLEAR-INPUT :MACRO-LEVEL :MACRO-ERROR
44                     :MACRO-EXECUTE :MACRO-PUSH :MACRO-POP :MACRO-QUERY :MACRO-PREVIOUS-ARRAY
45                     . ,OPS))))
46    #'MACRO-STREAM-IO))
47
48(DEFSELECT (MACRO-STREAM-IO MACRO-STREAM-DEFAULT-HANDLER T)
49  (:WHICH-OPERATIONS ()
50   MACRO-OPERATIONS)
51  (:UNTYI (CH)
52   (SETQ MACRO-UNTYI CH))
53  ((:TYI :ANY-TYI :MOUSE-OR-KBD-TYI
54    :TYI-NO-HANG :ANY-TYI-NO-HANG :MOUSE-OR-KBD-TYI-NO-HANG) ()
55   (COND (MACRO-UNTYI (PROG1 MACRO-UNTYI (SETQ MACRO-UNTYI NIL)))
56         (MACRO-READING
57          (MACRO-UPDATE-LEVEL)
58          (FUNCALL MACRO-STREAM SI:**DEFSELECT-OP**))
59         (T (MACRO-TYI SI:**DEFSELECT-OP**))))
60  (:LISTEN ()
61   (COND (MACRO-UNTYI T)
62         ((OR MACRO-READING
63              (NULL MACRO-CURRENT-ARRAY)
64              (NULL (MACRO-DEFAULT-COUNT MACRO-CURRENT-ARRAY))
65              (MEMQ (AREF MACRO-CURRENT-ARRAY (MACRO-POSITION MACRO-CURRENT-ARRAY))
66                    '(*SPACE* *MOUSE* *MICE* NIL)))
67          (FUNCALL MACRO-STREAM ':LISTEN))
68         (T T)))
69  (:MACRO-LEVEL ()
70   (1+ MACRO-LEVEL))
71  (:MACRO-ERROR ()                      ;Return T if we were playing back.
72   (PROG1 (AND MACRO-CURRENT-ARRAY (MACRO-DEFAULT-COUNT MACRO-CURRENT-ARRAY))
73          (MACRO-STOP NIL)))
74  (:CLEAR-INPUT ()
75   (MACRO-STOP NIL)
76   (FUNCALL MACRO-STREAM ':CLEAR-INPUT))
77  (:MACRO-EXECUTE (&OPTIONAL ARRAY TIMES)
78   (OR ARRAY (SETQ ARRAY MACRO-PREVIOUS-ARRAY))
79   (MACRO-PUSH-LEVEL (MACRO-STORE ARRAY))
80   (AND TIMES
81        (SETF (MACRO-COUNT ARRAY) TIMES)))
82  (:MACRO-PUSH (&OPTIONAL N)
83   (AND MACRO-CURRENT-ARRAY             ;Erase the command that caused this to happen
84        N
85        (SETF (MACRO-POSITION MACRO-CURRENT-ARRAY)
86              (- (MACRO-POSITION MACRO-CURRENT-ARRAY) N)))
87   (MACRO-PUSH-LEVEL (MACRO-STORE)))
88  (:MACRO-POP (&OPTIONAL N TIMES)
89   (AND MACRO-CURRENT-ARRAY
90        N
91        (SETF (MACRO-POSITION MACRO-CURRENT-ARRAY)
92              (- (MACRO-POSITION MACRO-CURRENT-ARRAY) N)))
93   (MACRO-REPEAT TIMES))
94  (:MACRO-QUERY ()
95   (MACRO-STORE '*SPACE*))
96  (:MACRO-PREVIOUS-ARRAY ()
97   MACRO-PREVIOUS-ARRAY))
98
99(DEFUN MACRO-STREAM-DEFAULT-HANDLER (OP &REST REST)
100  (IF (MEMQ OP MACRO-OPERATIONS)
101      (LEXPR-FUNCALL MACRO-STREAM OP REST)
102      (STREAM-DEFAULT-HANDLER 'MACRO-STREAM-IO OP (CAR REST) (CDR REST))))
103
104(DEFUN MACRO-TYI (&OPTIONAL (OP ':TYI))
105  (DO ((CH) (TEM) (NUMARG) (FLAG) (TEM2) (SUPPRESS))
106      (())
107   (*CATCH 'MACRO-LOOP
108    (COND ((AND MACRO-CURRENT-ARRAY (SETQ TEM2 (MACRO-DEFAULT-COUNT MACRO-CURRENT-ARRAY)))
109           (SETQ TEM (MACRO-POSITION MACRO-CURRENT-ARRAY)
110                 CH (AREF MACRO-CURRENT-ARRAY TEM))
111           (COND ((EQ CH '*SPACE*)
112                  (SELECTQ (FUNCALL MACRO-STREAM ':TYI)
113                   (#\SP
114                    (SETQ CH '*IGNORE*))
115                   ((#/? #\HELP)
116                    (FORMAT T "~&You are in an interactive macro.
117Space continues on, Rubout skips this one, Form refreshes the screen,
118Control-R enters a typein macro level (Backnext R exits), anything else exits.")
119                    (*THROW 'MACRO-LOOP NIL))
120                   (#\RUBOUT
121                    (SETQ TEM (MACRO-LENGTH MACRO-CURRENT-ARRAY)
122                          CH '*IGNORE*))
123                   ((#/R #/r)
124                    (SETQ CH NIL))
125                   (#\FF
126                    (RETURN #\FF))
127                   (#/.
128                    (SETF (MACRO-DEFAULT-COUNT MACRO-CURRENT-ARRAY) 0)
129                    (SETF (MACRO-COUNT MACRO-CURRENT-ARRAY) 0)
130                    (SETQ CH '*IGNORE*))
131                   (#/!
132                    (ASET '*RUN* MACRO-CURRENT-ARRAY TEM)
133                    (SETQ CH '*IGNORE*))
134                   (OTHERWISE
135                    (MACRO-STOP 1)
136                    (*THROW 'MACRO-LOOP NIL))))
137                 ((MEMQ CH '(*MOUSE* *MICE*))
138                  (AND (EQ CH '*MOUSE*) (FORMAT T "~&Use the mouse.~%"))
139                  (SETQ CH (FUNCALL MACRO-STREAM ':MOUSE-OR-KBD-TYI))
140                  (COND ((LDB-TEST %%KBD-MOUSE CH)
141                         (ASET '*MICE* MACRO-CURRENT-ARRAY TEM)
142                         (RETURN CH))
143                        (T
144                         (ASET '*MOUSE* MACRO-CURRENT-ARRAY TEM)
145                         (SETQ CH '*IGNORE*)))))
146           (COND ((AND (ZEROP TEM)
147                       (EQ TEM2 '*REPEAT*)
148                       (MEMQ ':MACRO-TERMINATE MACRO-OPERATIONS)
149                       (FUNCALL MACRO-STREAM ':MACRO-TERMINATE))
150                  (COND (( (SETQ MACRO-LEVEL (1- MACRO-LEVEL)) 0)
151                         (SETQ MACRO-CURRENT-ARRAY
152                               (AREF MACRO-LEVEL-ARRAY MACRO-LEVEL)))
153                        (T
154                         (SETQ MACRO-CURRENT-ARRAY NIL))))
155                 ((< TEM (MACRO-LENGTH MACRO-CURRENT-ARRAY))
156                  (SETF (MACRO-POSITION MACRO-CURRENT-ARRAY) (1+ TEM)))
157                 ((EQ TEM2 '*REPEAT*)
158                  (SETF (MACRO-POSITION MACRO-CURRENT-ARRAY) 0))
159                 ((> (SETQ TEM (1- (MACRO-COUNT MACRO-CURRENT-ARRAY))) 0)
160                  (SETF (MACRO-COUNT MACRO-CURRENT-ARRAY) TEM)
161                  (SETF (MACRO-POSITION MACRO-CURRENT-ARRAY) 0))
162                 (( (SETQ MACRO-LEVEL (1- MACRO-LEVEL)) 0)
163                  (SETQ MACRO-CURRENT-ARRAY (AREF MACRO-LEVEL-ARRAY MACRO-LEVEL)))
164                 (T
165                  (SETQ MACRO-CURRENT-ARRAY NIL)))
166           (COND ((NUMBERP CH) (OR SUPPRESS (RETURN CH)))
167                 ((MEMQ CH '(*RUN* *IGNORE*)))
168                 ((AND (LISTP CH) (EQ (CAR CH) '*A*))
169                  (LET ((X (MACRO-A-VALUE CH)))
170                    (SETF (MACRO-A-VALUE CH) (+ X (MACRO-A-STEP CH)))
171                    (OR SUPPRESS (RETURN X))))
172                 (T (MACRO-PUSH-LEVEL CH))))
173          (T
174           (MACRO-UPDATE-LEVEL)
175           (MULTIPLE-VALUE (CH TEM) (FUNCALL MACRO-STREAM OP))
176           (COND (FLAG
177                  (SETQ CH (CHAR-UPCASE CH))
178                  (COND ((AND ( CH #/0) ( CH #/9))
179                         (SETQ NUMARG (+ (- CH #/0) (* (OR NUMARG 0) 10.))))
180                        (T
181                         (SETQ FLAG NIL)
182                         (SELECTQ CH
183                           (#/C
184                            (SETQ TEM (MACRO-DO-READ "Macro to call: "))
185                            (OR (SETQ TEM (GET TEM 'MACRO-STREAM-MACRO)) (MACRO-BARF))
186                            (MACRO-STORE TEM)
187                            (OR SUPPRESS (MACRO-PUSH-LEVEL TEM)))
188                           (#/D
189                            (SETQ SUPPRESS MACRO-LEVEL)
190                            (MACRO-PUSH-LEVEL (MACRO-MAKE-NAMED-MACRO)))
191                           (#/M
192                            (MACRO-PUSH-LEVEL (MACRO-STORE (MACRO-MAKE-NAMED-MACRO))))
193                           (#/P
194                            (MACRO-PUSH-LEVEL (MACRO-STORE)))
195                           (#/R
196                            (MACRO-REPEAT NUMARG)
197                            (AND (EQ SUPPRESS MACRO-LEVEL) (SETQ SUPPRESS NIL)))
198                           (#/S
199                            (MACRO-STOP NUMARG))
200                           (#/T
201                            (MACRO-PUSH-LEVEL (MACRO-STORE NIL)))
202                           (#/U
203                            (MACRO-PUSH-LEVEL NIL))
204                           (#\SP
205                            (MACRO-STORE '*SPACE*))
206                           (#/A
207                            (LET ((STR (MACRO-READ-STRING
208                                         "Initial character (type a one-character string):")))
209                              (OR (= (STRING-LENGTH STR) 1) (MACRO-BARF))
210                              (LET ((VAL (AREF STR 0))
211                                    (NUM (MACRO-READ-NUMBER
212                                  "Amount by which to increase it (type a decimal number):")))
213                                (MACRO-STORE (MAKE-MACRO-A MACRO-A-VALUE (+ VAL NUM)
214                                                           MACRO-A-STEP NUM
215                                                           MACRO-A-INITIAL-VALUE VAL))
216                                (OR SUPPRESS (RETURN VAL)))))
217                           (#\HELP
218                            (FORMAT T "~&Macro commands are:
219P push a level of macro, R end and repeat arg times, C call a macro by name,
220S stop macro definition, U allow typein now only, T allow typein in expansion too.
221M define a named macro, D define a named macro but don't execute as building.
222Space enter macro query, A store an increasing character string.")
223                            (SETQ FLAG T))
224                           (OTHERWISE
225                            (MACRO-BARF))))))
226                 ((EQ CH MACRO-ESCAPE-CHAR)
227                  (SETQ FLAG T NUMARG NIL))
228                 (T
229                  (AND (NUMBERP CH) (MACRO-STORE (IF (LDB-TEST %%KBD-MOUSE CH) '*MOUSE* CH)))
230                  (OR SUPPRESS (RETURN CH TEM)))))))))
231
232(DEFUN MACRO-PUSH-LEVEL (MAC)
233  (COND (MAC
234          (AND (SYMBOLP MAC) (SETQ MAC (GET MAC 'MACRO-STREAM-MACRO)))
235          (OR (ARRAYP MAC) (MACRO-BARF))))
236  (SETQ MACRO-LEVEL (1+ MACRO-LEVEL)
237        MACRO-CURRENT-ARRAY MAC)
238  (ASET MAC MACRO-LEVEL-ARRAY MACRO-LEVEL)
239  (COND (MAC
240          (SETF (MACRO-POSITION MAC) 0)
241          (SETF (MACRO-COUNT MAC) (MACRO-DEFAULT-COUNT MAC))
242          (DO ((I 0 (1+ I))
243               (X)
244               (LIM (MACRO-LENGTH MAC)))
245              ((> I LIM))
246            (SETQ X (AREF MAC I))
247            (COND ((EQ '*RUN* X)
248                   (ASET '*SPACE* MAC I))
249                  ((EQ '*MICE* X)
250                   (ASET '*MOUSE* MAC I))
251                  ((AND (LISTP X) (EQ (CAR X) '*A*))
252                   (SETF (MACRO-A-VALUE X) (MACRO-A-INITIAL-VALUE X)))
253                  )))))
254
255(DEFUN MACRO-STORE (&OPTIONAL (THING T))
256  (AND (EQ THING T) (SETQ THING (MAKE-MACRO-ARRAY)))
257  (AND MACRO-CURRENT-ARRAY (ARRAY-PUSH-EXTEND MACRO-CURRENT-ARRAY THING))
258  THING)
259
260(DEFUN MACRO-BARF ()
261  (BEEP)
262  (*THROW 'MACRO-LOOP NIL))
263
264(DEFUN MACRO-REPEAT (ARG &AUX (TEM -1))
265  (AND (< MACRO-LEVEL 0) (MACRO-BARF))
266  (COND (MACRO-CURRENT-ARRAY
267          (OR ARG (SETQ ARG '*REPEAT*))
268          (SETF (MACRO-DEFAULT-COUNT MACRO-CURRENT-ARRAY) ARG)
269          (SETQ TEM (1- (MACRO-POSITION MACRO-CURRENT-ARRAY)))
270          (SETF (MACRO-LENGTH MACRO-CURRENT-ARRAY) TEM)
271          (SETQ MACRO-PREVIOUS-ARRAY MACRO-CURRENT-ARRAY)))
272  (COND ((AND ( TEM 0) (NUMBERP ARG) (> ARG 1))
273         (SETF (MACRO-POSITION MACRO-CURRENT-ARRAY) 0)
274         (SETF (MACRO-COUNT MACRO-CURRENT-ARRAY) (1- ARG)))
275        ((EQ ARG '*REPEAT*)
276         (SETF (MACRO-POSITION MACRO-CURRENT-ARRAY) 0))
277        (( (SETQ MACRO-LEVEL (1- MACRO-LEVEL)) 0)
278         (SETQ MACRO-CURRENT-ARRAY
279               (AREF MACRO-LEVEL-ARRAY MACRO-LEVEL)))
280        (T (SETQ MACRO-CURRENT-ARRAY NIL))))
281
282(DEFUN MACRO-MAKE-NAMED-MACRO (&AUX TEM MAC)
283  (SETQ TEM (MACRO-DO-READ "Name of macro to define: "))
284  (OR (SYMBOLP TEM) (MACRO-BARF))
285  (SETQ MAC (MAKE-MACRO-ARRAY))
286  (PUTPROP TEM MAC 'MACRO-STREAM-MACRO)
287  (SETF (MACRO-NAME MAC) (STRING TEM))
288  MAC)
289
290(DEFUN MACRO-READ-STRING (STR &AUX (MACRO-READING T) (MACRO-REDIS-LEVEL -1))
291  (IF (MEMQ ':READ-MACRO-LINE MACRO-OPERATIONS)
292      (FUNCALL MACRO-STREAM ':READ-MACRO-LINE STR)
293      (PRINC STR MACRO-STREAM)
294      (READLINE MACRO-STREAM)))
295
296(DEFUN MACRO-DO-READ (STR)
297  (INTERN (STRING-UPCASE (STRING-TRIM '(#\SP #\TAB) (MACRO-READ-STRING STR)))
298          ""))
299
300(DEFUN MACRO-READ-NUMBER (STR)
301  (LET ((NUM (READ-FROM-STRING (MACRO-READ-STRING STR))))
302    (OR (NUMBERP NUM) (MACRO-BARF))
303    NUM))
304
305(DEFUN MACRO-STOP (NUM)
306  (SETQ MACRO-LEVEL (MAX -1 (- MACRO-LEVEL (OR NUM 20)))
307        MACRO-CURRENT-ARRAY (AND ( MACRO-LEVEL 0)
308                                 (AREF MACRO-LEVEL-ARRAY MACRO-LEVEL))))
309
310(DEFUN MACRO-UPDATE-LEVEL ()
311  (COND ((AND ( MACRO-LEVEL MACRO-REDIS-LEVEL) (MEMQ ':SET-MACRO-LEVEL MACRO-OPERATIONS))
312         (SETQ MACRO-REDIS-LEVEL MACRO-LEVEL)
313         (FUNCALL MACRO-STREAM ':SET-MACRO-LEVEL
314                  (AND (NOT (MINUSP MACRO-LEVEL))
315                       (FORMAT NIL "~D" (1+ MACRO-LEVEL)))))))
316
317;;; Handy things for saving out macros on disk and editing them
318(DEFMACRO DEFINE-KEYBOARD-MACRO (NAME (COUNT) . EXPANSION)
319  `(DEFINE-KEYBOARD-MACRO-1 ',NAME ,(OR COUNT 1) ',(COPYLIST EXPANSION)))
320
321(DEFUN DEFINE-KEYBOARD-MACRO-1 (NAME COUNT EXPANSION &AUX MACRO-ARRAY (LEN 0) STRING)
322  (SETQ STRING (STRING NAME)
323        NAME (INTERN STRING ""))
324  (DOLIST (THING EXPANSION)
325    (IF (STRINGP THING)
326        (SETQ LEN (+ LEN (STRING-LENGTH THING)))
327        (SETQ LEN (1+ LEN))))
328  (SETQ MACRO-ARRAY (MAKE-MACRO-ARRAY MAKE-ARRAY (NIL 'ART-Q LEN)
329                                      MACRO-LENGTH (1- LEN)
330                                      MACRO-DEFAULT-COUNT COUNT
331                                      MACRO-NAME STRING))
332  (DOLIST (THING EXPANSION)
333    (IF (STRINGP THING)
334        (APPEND-TO-ARRAY MACRO-ARRAY THING)
335        (COND ((NUMBERP THING))
336              ((STRING-EQUAL THING '*INPUT*)
337               (SETQ THING NIL))
338              ((STRING-EQUAL THING '*SPACE*)
339               (SETQ THING '*SPACE*))
340              ((STRING-EQUAL THING '*MOUSE*)
341               (SETQ THING '*MOUSE*))
342              ((STRING-EQUAL THING '*MICE*)
343               (SETQ THING '*MICE*))
344              (T
345               (FERROR NIL "~S is not a known macro expansion element." THING)))
346        (ARRAY-PUSH MACRO-ARRAY THING)))
347  (PUTPROP NAME MACRO-ARRAY 'MACRO-STREAM-MACRO)
348  NAME)
349
350(DEFUN PRINT-KEYBOARD-MACRO-DEFINITION (STREAM NAME &OPTIONAL MACRO-ARRAY)
351  (LET ((PACKAGE (PKG-FIND-PACKAGE "ZWEI"))
352        (BASE 'CHARACTER))
353    (SI:GRIND-TOP-LEVEL (GET-KEYBOARD-MACRO-DEFINITION NAME MACRO-ARRAY) 95. STREAM)))
354
355(DEFUN GET-KEYBOARD-MACRO-DEFINITION (NAME MACRO-ARRAY)
356  (OR MACRO-ARRAY (SETQ MACRO-ARRAY (GET NAME 'MACRO-STREAM-MACRO)))
357  (SETQ NAME (INTERN NAME "ZWEI"))
358  (DO ((I 0 (1+ I))
359       (LEN (1+ (MACRO-LENGTH MACRO-ARRAY)))
360       (THING)
361       (STATE NIL)
362       (LIST NIL)
363       (STRING (MAKE-ARRAY NIL 'ART-STRING 10. NIL 1)))
364      (( I LEN)
365       `(DEFINE-KEYBOARD-MACRO ,NAME () . ,(NREVERSE LIST)))
366    (SETQ THING (AREF MACRO-ARRAY I))
367    (COND ((OR (SYMBOLP THING) (LDB-TEST %%KBD-CONTROL-META THING))
368           (COND (STATE
369                  (PUSH (STRING-APPEND STRING) LIST)
370                  (SETQ STATE NIL)))
371           (COND ((NUMBERP THING))
372                 ((NULL THING)
373                  (SETQ THING '*INPUT*)))
374           (PUSH THING LIST))
375          (T
376           (COND ((NOT STATE)
377                  (STORE-ARRAY-LEADER 0 STRING 0)
378                  (SETQ STATE T)))
379           (ARRAY-PUSH-EXTEND STRING THING)))))
380
381(DEFUN (CHARACTER SI:PRINC-FUNCTION) (-N STREAM)
382  (FORMAT STREAM "~@C" (- -N)))
Note: See TracBrowser for help on using the browser.