|
0
|
1 ;;; teco.el --- Teco interpreter for Gnu Emacs, version 1.
|
|
|
2
|
|
|
3 (require 'backquote)
|
|
|
4 ;; This code has been tested some, but no doubt contains a zillion bugs.
|
|
|
5 ;; You have been warned.
|
|
|
6
|
|
|
7 ;; Written by Dale R. Worley based on a C implementation by Matt Fichtenbaum.
|
|
|
8 ;; Please send comments, bug fixes, enhancements, etc. to drw@math.mit.edu.
|
|
|
9
|
|
|
10 ;; Emacs Lisp version copyright (C) 1991 by Dale R. Worley.
|
|
|
11 ;; Do what you will with it.
|
|
|
12
|
|
|
13 ;; Since much of this code is translated from the C version by
|
|
|
14 ;; Matt Fichtenbaum, I include his copyright notice:
|
|
|
15 ;; TECO for Ultrix. Copyright 1986 Matt Fichtenbaum.
|
|
|
16 ;; This program and its components belong to GenRad Inc, Concord MA 01742.
|
|
|
17 ;; They may be copied if this copyright notice is included.
|
|
|
18
|
|
|
19 ;; To invoke directly, do:
|
|
|
20 ;; (global-set-key ?\C-z 'teco-command)
|
|
|
21 ;; (autoload teco-command "teco"
|
|
|
22 ;; "Read and execute a Teco command string."
|
|
|
23 ;; t nil)
|
|
|
24
|
|
|
25 ;; Differences from other Tecos:
|
|
|
26 ;; Character positions in the buffer are numbered in the Emacs way: The first
|
|
|
27 ;; character is numbered 1 (or (point-min) if narrowing is in effect). The
|
|
|
28 ;; B command returns that number.
|
|
|
29 ;; Ends of lines are represented by a single character (newline), so C and R
|
|
|
30 ;; skip over them, rather than 2C and 2R.
|
|
|
31 ;; All file I/O is left to the underlying Emacs. Thus, almost all Ex commands
|
|
|
32 ;; are omitted.
|
|
|
33
|
|
|
34 ;; Command set:
|
|
|
35 ;; NUL Not a command.
|
|
|
36 ;; ^A Output message to terminal (argument ends with ^A)
|
|
|
37 ;; ^C Exit macro
|
|
|
38 ;; ^C^C Stop execution
|
|
|
39 ;; ^D Set radix to decimal
|
|
|
40 ;; ^EA (match char) Match alphabetics
|
|
|
41 ;; ^EC (match char) Match symbol constituents
|
|
|
42 ;; ^ED (match char) Match numerics
|
|
|
43 ;; ^EGq (match char) Match any char in q-reg
|
|
|
44 ;; ^EL (match char) Match line terminators
|
|
|
45 ;; ^EQq (string char) Use contents of q-reg
|
|
|
46 ;; ^ER (match char) Match alphanumerics
|
|
|
47 ;; ^ES (match char) Match non-null space/tab
|
|
|
48 ;; ^EV (match char) Match lower case alphabetic
|
|
|
49 ;; ^EW (match char) Match upper case alphabetic
|
|
|
50 ;; ^EX (match char) Match any char
|
|
|
51 ;; ^G^G (type-in) Kill command string
|
|
|
52 ;; ^G<sp> (type-in) Retype current command line
|
|
|
53 ;; ^G* (type-in) Retype current command input
|
|
|
54 ;; TAB Insert tab and text
|
|
|
55 ;; LF Line terminator; Ignored in commands
|
|
|
56 ;; VT Ignored in commands
|
|
|
57 ;; FF Ignored in commands
|
|
|
58 ;; CR Ignored in commands
|
|
|
59 ;; ^Nx (match char) Match all but x
|
|
|
60 ;; ^O Set radix to octal
|
|
|
61 ;; ^P Find matching parenthesis
|
|
|
62 ;; ^Q Convert line argument into character argument
|
|
|
63 ;; ^Qx (string char) Use x literally
|
|
|
64 ;; n^R Set radix to n
|
|
|
65 ;; :^R Enter recursive edit
|
|
|
66 ;; ^S -(length of last referenced string)
|
|
|
67 ;; ^S (match char) match separator char
|
|
|
68 ;; ^T Ascii value of next character typed
|
|
|
69 ;; n^T Output Ascii character with value n
|
|
|
70 ;; ^U (type-in) Kill command line
|
|
|
71 ;; ^Uq Put text argument into q-reg
|
|
|
72 ;; n^Uq Put Ascii character 'n' into q-reg
|
|
|
73 ;; :^Uq Append text argument to q-reg
|
|
|
74 ;; n:^Uq Append character 'n' to q-reg
|
|
|
75 ;; ^X Set/get search mode flag
|
|
|
76 ;; ^X (match char) Match any character
|
|
|
77 ;; ^Y Equivalent to '.+^S,.'
|
|
|
78 ;; ^Z Not a Teco command
|
|
|
79 ;; ESC String terminator; absorbs arguments
|
|
|
80 ;; ESC ESC (type-in) End command
|
|
|
81 ;; ^\ Not a Teco command
|
|
|
82 ;; ^] Not a Teco command
|
|
|
83 ;; ^^x Ascii value of the character x
|
|
|
84 ;; ^_ One's complement (logical NOT)
|
|
|
85 ;; ! Define label (argument ends with !)
|
|
|
86 ;; " Start conditional
|
|
|
87 ;; n"< Test for less than zero
|
|
|
88 ;; n"> Test for greater than zero
|
|
|
89 ;; n"= Test for equal to zero
|
|
|
90 ;; n"A Test for alphabetic
|
|
|
91 ;; n"C Test for symbol constituent
|
|
|
92 ;; n"D Test for numeric
|
|
|
93 ;; n"E Test for equal to zero
|
|
|
94 ;; n"F Test for false
|
|
|
95 ;; n"G Test for greater than zero
|
|
|
96 ;; n"L Test for less than zero
|
|
|
97 ;; n"N Test for not equal to zero
|
|
|
98 ;; n"R Test for alphanumeric
|
|
|
99 ;; n"S Test for successful
|
|
|
100 ;; n"T Test for true
|
|
|
101 ;; n"U Test for unsuccessful
|
|
|
102 ;; n"V Test for lower case
|
|
|
103 ;; n"W Test for upper case
|
|
|
104 ;; # Logical OR
|
|
|
105 ;; $ Not a Teco command
|
|
|
106 ;; n%q Add n to q-reg and return result
|
|
|
107 ;; & Logical AND
|
|
|
108 ;; ' End conditional
|
|
|
109 ;; ( Expression grouping
|
|
|
110 ;; ) Expression grouping
|
|
|
111 ;; * Multiplication
|
|
|
112 ;; + Addition
|
|
|
113 ;; , Argument separator
|
|
|
114 ;; - Subtraction or negation
|
|
|
115 ;; . Current pointer position
|
|
|
116 ;; / Division
|
|
|
117 ;; 0-9 Digit
|
|
|
118 ;; n< Iterate n times
|
|
|
119 ;; = Type in decimal
|
|
|
120 ;; := Type in decimal, no newline
|
|
|
121 ;; = Type in octal
|
|
|
122 ;; := Type in octal, no newline
|
|
|
123 ;; = Type in hexadecimal
|
|
|
124 ;; := Type in hexadecimal, no newline
|
|
|
125 ;; :: Make next search a compare
|
|
|
126 ;; > End iteration
|
|
|
127 ;; n:A Get Ascii code of character at relative position n
|
|
|
128 ;; B Character position of beginning of buffer
|
|
|
129 ;; nC Advance n characters
|
|
|
130 ;; nD Delete n characters
|
|
|
131 ;; n,mD Delete characters between n and m
|
|
|
132 ;; Gq Get string from q-reg into buffer
|
|
|
133 ;; :Gq Type out q-reg
|
|
|
134 ;; H Equivalent to 'B,Z'
|
|
|
135 ;; I Insert text argument
|
|
|
136 ;; nJ Move pointer to character n
|
|
|
137 ;; nK Kill n lines
|
|
|
138 ;; n,mK Kill characters between n and m
|
|
|
139 ;; nL Advance n lines
|
|
|
140 ;; Mq Execute string in q-reg
|
|
|
141 ;; O Goto label
|
|
|
142 ;; nO Go to n-th label in list (0-origin)
|
|
|
143 ;; Qq Number in q-reg
|
|
|
144 ;; nQq Ascii value of n-th character in q-reg
|
|
|
145 ;; :Qq Size of text in q-reg
|
|
|
146 ;; nR Back up n characters
|
|
|
147 ;; nS Search
|
|
|
148 ;; nT Type n lines
|
|
|
149 ;; n,mT Type chars from n to m
|
|
|
150 ;; nUq Put number n into q-reg
|
|
|
151 ;; nV Type n lines around pointer
|
|
|
152 ;; nXq Put n lines into q-reg
|
|
|
153 ;; n,mXq Put characters from n to m into q-reg
|
|
|
154 ;; n:Xq Append n lines to q-reg q
|
|
|
155 ;; n,m:Xq Append characters from n to m into q-reg
|
|
|
156 ;; Z Pointer position at end of buffer
|
|
|
157 ;; [q Put q-reg on stack
|
|
|
158 ;; \ Value of digit string in buffer
|
|
|
159 ;; n\ Convert n to digits and insert in buffer
|
|
|
160 ;; ]q Pop q-reg from stack
|
|
|
161 ;; :]q Test whether stack is empty and return value
|
|
|
162 ;; ` Not a Teco command
|
|
|
163 ;; a-z Treated the same as A-Z
|
|
|
164 ;; { Not a Teco command
|
|
|
165 ;; | Conditional 'else'
|
|
|
166 ;; } Not a Teco comand
|
|
|
167 ;; ~ Not a Teco command
|
|
|
168 ;; DEL Delete last character typed in
|
|
|
169
|
|
|
170
|
|
|
171 ;; set a range of elements of an array to a value
|
|
|
172 (defun teco-set-elements (array start end value)
|
|
|
173 (let ((i start))
|
|
|
174 (while (<= i end)
|
|
|
175 (aset array i value)
|
|
|
176 (setq i (1+ i)))))
|
|
|
177
|
|
|
178 ;; set a range of elements of an array to their indexes plus an offset
|
|
|
179 (defun teco-set-elements-index (array start end offset)
|
|
|
180 (let ((i start))
|
|
|
181 (while (<= i end)
|
|
|
182 (aset array i (+ i offset))
|
|
|
183 (setq i (1+ i)))))
|
|
|
184
|
|
|
185 (defvar teco-command-string ""
|
|
|
186 "The current command string being executed.")
|
|
|
187
|
|
|
188 (defvar teco-command-pointer nil
|
|
|
189 "Pointer into teco-command-string showing next character to be executed.")
|
|
|
190
|
|
|
191 (defvar teco-ctrl-r 10
|
|
|
192 "Current number radix.")
|
|
|
193
|
|
|
194 (defvar teco-digit-switch nil
|
|
|
195 "Set if we have just executed a digit.")
|
|
|
196
|
|
|
197 (defvar teco-exp-exp nil
|
|
|
198 "Expression value preceeding operator.")
|
|
|
199
|
|
|
200 (defvar teco-exp-val1 nil
|
|
|
201 "Current argument value.")
|
|
|
202
|
|
|
203 (defvar teco-exp-val2 nil
|
|
|
204 "Argument before comma.")
|
|
|
205
|
|
|
206 (defvar teco-exp-flag1 nil
|
|
|
207 "t if argument is present.")
|
|
|
208
|
|
|
209 (defvar teco-exp-flag2 nil
|
|
|
210 "t if argument before comma is present.")
|
|
|
211
|
|
|
212 (defvar teco-exp-op nil
|
|
|
213 "Pending arithmetic operation on argument.")
|
|
|
214
|
|
|
215 (defvar teco-exp-stack nil
|
|
|
216 "Stack for parenthesized expressions.")
|
|
|
217
|
|
|
218 (defvar teco-macro-stack nil
|
|
|
219 "Stack for macro invocations.")
|
|
|
220
|
|
|
221 (defvar teco-mapch-l nil
|
|
|
222 "Translation table to lower-case letters.")
|
|
|
223
|
|
|
224 (setq teco-mapch-l (make-vector 256 0))
|
|
|
225 (teco-set-elements-index teco-mapch-l 0 255 0)
|
|
|
226 (teco-set-elements-index teco-mapch-l ?A ?Z (- ?a ?A))
|
|
|
227
|
|
|
228 (defvar teco-trace nil
|
|
|
229 "t if tracing is on.")
|
|
|
230
|
|
|
231 (defvar teco-at-flag nil
|
|
|
232 "t if an @ flag is pending.")
|
|
|
233
|
|
|
234 (defvar teco-colon-flag nil
|
|
|
235 "1 if a : flag is pending, 2 if a :: flag is pending.")
|
|
|
236
|
|
|
237 (defvar teco-qspec-valid nil
|
|
|
238 "Flags describing whether a character is a vaid q-register name.
|
|
|
239 3 means yes, 2 means yes but only for file and search operations.")
|
|
|
240
|
|
|
241 (setq teco-qspec-valid (make-vector 256 0))
|
|
|
242 (teco-set-elements teco-qspec-valid ?a ?z 3)
|
|
|
243 (teco-set-elements teco-qspec-valid ?0 ?9 3)
|
|
|
244 (aset teco-qspec-valid ?_ 2)
|
|
|
245 (aset teco-qspec-valid ?* 2)
|
|
|
246 (aset teco-qspec-valid ?% 2)
|
|
|
247 (aset teco-qspec-valid ?# 2)
|
|
|
248
|
|
|
249 (defvar teco-exec-flags 0
|
|
|
250 "Flags for iteration in process, ei macro, etc.")
|
|
|
251
|
|
|
252 (defvar teco-iteration-stack nil
|
|
|
253 "Iteration list.")
|
|
|
254
|
|
|
255 (defvar teco-cond-stack nil
|
|
|
256 "Conditional stack.")
|
|
|
257
|
|
|
258 (defvar teco-qreg-text (make-vector 256 "")
|
|
|
259 "The text contents of the q-registers.")
|
|
|
260
|
|
|
261 (defvar teco-qreg-number (make-vector 256 0)
|
|
|
262 "The number contents of the q-registers.")
|
|
|
263
|
|
|
264 (defvar teco-qreg-stack nil
|
|
|
265 "The stack of saved q-registers.")
|
|
|
266
|
|
|
267 (defconst teco-prompt "*"
|
|
|
268 "*Prompt to be used when inputting Teco command.")
|
|
|
269
|
|
|
270 (defconst teco-exec-1 (make-vector 256 nil)
|
|
|
271 "Names of routines handling type 1 characters (characters that are
|
|
|
272 part of expression processing).")
|
|
|
273
|
|
|
274 (defconst teco-exec-2 (make-vector 256 nil)
|
|
|
275 "Names of routines handling type 2 characters (characters that are
|
|
|
276 not part of expression processing).")
|
|
|
277
|
|
|
278 (defvar teco-last-search-string ""
|
|
|
279 "Last string searched for.")
|
|
|
280
|
|
|
281 (defvar teco-last-search-regexp ""
|
|
|
282 "Regexp version of teco-last-search-string.")
|
|
|
283
|
|
|
284 (defmacro teco-define-type-1 (char &rest body)
|
|
|
285 "Define the code to process a type 1 character.
|
|
|
286 Transforms
|
|
|
287 (teco-define-type-1 ?x
|
|
|
288 code ...)
|
|
|
289 into
|
|
|
290 (defun teco-type-1-x ()
|
|
|
291 code ...)
|
|
|
292 and does
|
|
|
293 (aset teco-exec-1 ?x 'teco-type-1-x)"
|
|
|
294 (let ((s (intern (concat "teco-type-1-" (char-to-string char)))))
|
|
|
295 (` (progn
|
|
|
296 (defun (, s) ()
|
|
|
297 (,@ body))
|
|
|
298 (aset teco-exec-1 (, char) '(, s))))))
|
|
|
299
|
|
|
300 (defmacro teco-define-type-2 (char &rest body)
|
|
|
301 "Define the code to process a type 2 character.
|
|
|
302 Transforms
|
|
|
303 (teco-define-type-2 ?x
|
|
|
304 code ...)
|
|
|
305 into
|
|
|
306 (defun teco-type-2-x ()
|
|
|
307 code ...)
|
|
|
308 and does
|
|
|
309 (aset teco-exec-2 ?x 'teco-type-2-x)"
|
|
|
310 (let ((s (intern (concat "teco-type-2-" (char-to-string char)))))
|
|
|
311 (` (progn
|
|
|
312 (defun (, s) ()
|
|
|
313 (,@ body))
|
|
|
314 (aset teco-exec-2 (, char) '(, s))))))
|
|
|
315
|
|
|
316 (defconst teco-char-types (make-vector 256 0)
|
|
|
317 "Define the characteristics of characters, as tested by \":
|
|
|
318 1 alphabetic
|
|
|
319 2 alphabetic, $, or .
|
|
|
320 4 digit
|
|
|
321 8 alphabetic or digit
|
|
|
322 16 lower-case alphabetic
|
|
|
323 32 upper-case alphabetic")
|
|
|
324
|
|
|
325 (teco-set-elements teco-char-types ?0 ?9 (+ 4 8))
|
|
|
326 (teco-set-elements teco-char-types ?A ?Z (+ 1 2 8 32))
|
|
|
327 (teco-set-elements teco-char-types ?a ?z (+ 1 2 8 16))
|
|
|
328 (aset teco-char-types ?$ 2)
|
|
|
329 (aset teco-char-types ?. 2)
|
|
|
330
|
|
|
331 (defconst teco-error-texts '(("BNI" . "> not in iteration")
|
|
|
332 ("CPQ" . "Can't pop Q register")
|
|
|
333 ("COF" . "Can't open output file ")
|
|
|
334 ("FNF" . "File not found ")
|
|
|
335 ("IEC" . "Invalid E character")
|
|
|
336 ("IFC" . "Invalid F character")
|
|
|
337 ("IIA" . "Invalid insert arg")
|
|
|
338 ("ILL" . "Invalid command")
|
|
|
339 ("ILN" . "Invalid number")
|
|
|
340 ("IPA" . "Invalid P arg")
|
|
|
341 ("IQC" . "Invalid \" character")
|
|
|
342 ("IQN" . "Invalid Q-reg name")
|
|
|
343 ("IRA" . "Invalid radix arg")
|
|
|
344 ("ISA" . "Invalid search arg")
|
|
|
345 ("ISS" . "Invalid search string")
|
|
|
346 ("IUC" . "Invalid ^ character")
|
|
|
347 ("LNF" . "Label not found")
|
|
|
348 ("MEM" . "Insufficient memory available")
|
|
|
349 ("MRP" . "Missing )")
|
|
|
350 ("NAB" . "No arg before ^_")
|
|
|
351 ("NAC" . "No arg before ,")
|
|
|
352 ("NAE" . "No arg before =")
|
|
|
353 ("NAP" . "No arg before )")
|
|
|
354 ("NAQ" . "No arg before \"")
|
|
|
355 ("NAS" . "No arg before ;")
|
|
|
356 ("NAU" . "No arg before U")
|
|
|
357 ("NFI" . "No file for input")
|
|
|
358 ("NFO" . "No file for output")
|
|
|
359 ("NYA" . "Numeric arg with Y")
|
|
|
360 ("OFO" . "Output file already open")
|
|
|
361 ("PDO" . "Pushdown list overflow")
|
|
|
362 ("POP" . "Pointer off page")
|
|
|
363 ("SNI" . "; not in iteration")
|
|
|
364 ("SRH" . "Search failure ")
|
|
|
365 ("STL" . "String too long")
|
|
|
366 ("UTC" . "Unterminated command")
|
|
|
367 ("UTM" . "Unterminated macro")
|
|
|
368 ("XAB" . "Execution interrupted")
|
|
|
369 ("YCA" . "Y command suppressed")
|
|
|
370 ("IWA" . "Invalid W arg")
|
|
|
371 ("NFR" . "Numeric arg with FR")
|
|
|
372 ("INT" . "Internal error")
|
|
|
373 ("EFI" . "EOF read from std input")
|
|
|
374 ("IAA" . "Invalid A arg")
|
|
|
375 ))
|
|
|
376
|
|
|
377 (defconst teco-spec-chars
|
|
|
378 [
|
|
|
379 0 1 0 0 ; ^@ ^A ^B ^C
|
|
|
380 0 64 0 0 ; ^D ^E ^F ^G
|
|
|
381 0 2 128 128 ; ^H ^I ^J ^K
|
|
|
382 128 0 64 0 ; ^L ^M ^N ^O
|
|
|
383 0 64 64 64 ; ^P ^Q ^R ^S
|
|
|
384 0 34 0 0 ; ^T ^U ^V ^W
|
|
|
385 64 0 0 0 ; ^X ^Y ^Z ^\[
|
|
|
386 0 0 1 0 ; ^\ ^\] ^^ ^_
|
|
|
387 0 1 16 0 ; ! \" #
|
|
|
388 0 0 0 16 ; $ % & '
|
|
|
389 0 0 0 0 ; \( \) * +
|
|
|
390 0 0 0 0 ; , - . /
|
|
|
391 0 0 0 0 ; 0 1 2 3
|
|
|
392 0 0 0 0 ; 4 5 6 7
|
|
|
393 0 0 0 0 ; 8 9 : ;
|
|
|
394 16 0 16 0 ; < = > ?
|
|
|
395 1 0 12 0 ; @ A B C
|
|
|
396 0 1 1 32 ; D E F G
|
|
|
397 0 6 0 0 ; H I J K
|
|
|
398 0 32 10 2 ; L M N O
|
|
|
399 0 32 4 10 ; P Q R S
|
|
|
400 0 32 0 4 ; T U V W
|
|
|
401 32 0 0 32 ; X Y Z \[
|
|
|
402 0 32 1 6 ; \ \] ^ _
|
|
|
403 0 0 12 0 ; ` a b c
|
|
|
404 0 1 1 32 ; d e f g
|
|
|
405 0 6 0 0 ; h i j k
|
|
|
406 0 32 10 2 ; l m n o
|
|
|
407 0 32 4 10 ; p q r s
|
|
|
408 0 32 0 4 ; t u v w
|
|
|
409 32 0 0 0 ; x y z {
|
|
|
410 16 0 0 0 ; | } ~ DEL
|
|
|
411 ]
|
|
|
412 "The special properties of characters:
|
|
|
413 1 skipto() special character
|
|
|
414 2 command with std text argument
|
|
|
415 4 E<char> takes a text argument
|
|
|
416 8 F<char> takes a text argument
|
|
|
417 16 char causes skipto() to exit
|
|
|
418 32 command with q-register argument
|
|
|
419 64 special char in search string
|
|
|
420 128 character is a line separator")
|
|
|
421
|
|
|
422
|
|
|
423 (defun teco-execute-command (string)
|
|
|
424 "Execute teco command string."
|
|
|
425 ;; Initialize everything
|
|
|
426 (let ((teco-command-string string)
|
|
|
427 (teco-command-pointer 0)
|
|
|
428 (teco-digit-switch nil)
|
|
|
429 (teco-exp-exp nil)
|
|
|
430 (teco-exp-val1 nil)
|
|
|
431 (teco-exp-val2 nil)
|
|
|
432 (teco-exp-flag1 nil)
|
|
|
433 (teco-exp-flag2 nil)
|
|
|
434 (teco-exp-op 'start)
|
|
|
435 (teco-trace nil)
|
|
|
436 (teco-at-flag nil)
|
|
|
437 (teco-colon-flag nil)
|
|
|
438 (teco-exec-flags 0)
|
|
|
439 (teco-iteration-stack nil)
|
|
|
440 (teco-cond-stack nil)
|
|
|
441 (teco-exp-stack nil)
|
|
|
442 (teco-macro-stack nil)
|
|
|
443 (teco-qreg-stack nil))
|
|
|
444 ;; initialize output
|
|
|
445 (teco-out-init)
|
|
|
446 ;; execute commands
|
|
|
447 (catch 'teco-exit
|
|
|
448 (while t
|
|
|
449 ;; get next command character
|
|
|
450 (let ((cmdc (teco-get-command0 teco-trace)))
|
|
|
451 ;; if it's ^, interpret the next character as a control character
|
|
|
452 (if (eq cmdc ?^)
|
|
|
453 (setq cmdc (logand (teco-get-command teco-trace) 31)))
|
|
|
454 (if (and (<= ?0 cmdc) (<= cmdc ?9))
|
|
|
455 ;; process a number
|
|
|
456 (progn
|
|
|
457 (setq cmdc (- cmdc ?0))
|
|
|
458 ;; check for invalid digit
|
|
|
459 (if (>= cmdc teco-ctrl-r)
|
|
|
460 (teco-error "ILN"))
|
|
|
461 (if teco-digit-switch
|
|
|
462 ;; later digits
|
|
|
463 (setq teco-exp-val1 (+ (* teco-exp-val1 teco-ctrl-r) cmdc))
|
|
|
464 ;; first digit
|
|
|
465 (setq teco-exp-val1 cmdc)
|
|
|
466 (setq teco-digit-switch t))
|
|
|
467 ;; indicate a value was read in
|
|
|
468 (setq teco-exp-flag1 t))
|
|
|
469 ;; not a digit
|
|
|
470 (setq teco-digit-switch nil)
|
|
|
471 ;; cannonicalize the case
|
|
|
472 (setq cmdc (aref teco-mapch-l cmdc))
|
|
|
473 ;; dispatch on the character, if it is a type 1 character
|
|
|
474 (let ((r (aref teco-exec-1 cmdc)))
|
|
|
475 (if r
|
|
|
476 (funcall r)
|
|
|
477 ;; if a value has been entered, process any pending operation
|
|
|
478 (if teco-exp-flag1
|
|
|
479 (cond ((eq teco-exp-op 'start)
|
|
|
480 nil)
|
|
|
481 ((eq teco-exp-op 'add)
|
|
|
482 (setq teco-exp-val1 (+ teco-exp-exp teco-exp-val1))
|
|
|
483 (setq teco-exp-op 'start))
|
|
|
484 ((eq teco-exp-op 'sub)
|
|
|
485 (setq teco-exp-val1 (- teco-exp-exp teco-exp-val1))
|
|
|
486 (setq teco-exp-op 'start))
|
|
|
487 ((eq teco-exp-op 'mult)
|
|
|
488 (setq teco-exp-val1 (* teco-exp-exp teco-exp-val1))
|
|
|
489 (setq teco-exp-op 'start))
|
|
|
490 ((eq teco-exp-op 'div)
|
|
|
491 (setq teco-exp-val1
|
|
|
492 (if (/= teco-exp-val1 0)
|
|
|
493 (/ teco-exp-exp teco-exp-val1)
|
|
|
494 0))
|
|
|
495 (setq teco-exp-op 'start))
|
|
|
496 ((eq teco-exp-op 'and)
|
|
|
497 (setq teco-exp-val1
|
|
|
498 (logand teco-exp-exp teco-exp-val1))
|
|
|
499 (setq teco-exp-op 'start))
|
|
|
500 ((eq teco-exp-op 'or)
|
|
|
501 (setq teco-exp-val1
|
|
|
502 (logior teco-exp-exp teco-exp-val1))
|
|
|
503 (setq teco-exp-op 'start))))
|
|
|
504 ;; dispatch on a type 2 character
|
|
|
505 (let ((r (aref teco-exec-2 cmdc)))
|
|
|
506 (if r
|
|
|
507 (funcall r)
|
|
|
508 (teco-error "ILL")))))))))))
|
|
|
509
|
|
|
510 ;; Type 1 commands
|
|
|
511
|
|
|
512 (teco-define-type-1
|
|
|
513 ?\m ; CR
|
|
|
514 nil)
|
|
|
515
|
|
|
516 (teco-define-type-1
|
|
|
517 ?\n ; LF
|
|
|
518 nil)
|
|
|
519
|
|
|
520 (teco-define-type-1
|
|
|
521 ?\^k ; VT
|
|
|
522 nil)
|
|
|
523
|
|
|
524 (teco-define-type-1
|
|
|
525 ?\^l ; FF
|
|
|
526 nil)
|
|
|
527
|
|
|
528 (teco-define-type-1
|
|
|
529 32 ; SPC
|
|
|
530 nil)
|
|
|
531
|
|
|
532 (teco-define-type-1
|
|
|
533 ?\e ; ESC
|
|
|
534 (if (teco-peek-command ?\e)
|
|
|
535 ;; ESC ESC terminates macro or command
|
|
|
536 (teco-pop-macro-stack)
|
|
|
537 ;; otherwise, consume argument
|
|
|
538 (setq teco-exp-flag1 nil)
|
|
|
539 (setq teco-exp-op 'start)))
|
|
|
540
|
|
|
541 (teco-define-type-1
|
|
|
542 ?! ; !
|
|
|
543 (while (/= (teco-get-command teco-trace) ?!)
|
|
|
544 nil))
|
|
|
545
|
|
|
546 (teco-define-type-1
|
|
|
547 ?@ ; @
|
|
|
548 ;; set at-flag
|
|
|
549 (setq teco-at-flag t))
|
|
|
550
|
|
|
551 (teco-define-type-1
|
|
|
552 ?: ; :
|
|
|
553 ;; is it '::'?
|
|
|
554 (if (teco-peek-command ?:)
|
|
|
555 (progn
|
|
|
556 ;; skip second colon
|
|
|
557 (teco-get-command teco-trace)
|
|
|
558 ;; set flag to show two colons
|
|
|
559 (setq teco-colon-flag 2))
|
|
|
560 ;; set flag to show one colon
|
|
|
561 (setq teco-colon-flag 1)))
|
|
|
562
|
|
|
563 (teco-define-type-1
|
|
|
564 ?? ; ?
|
|
|
565 ;; toggle trace
|
|
|
566 (setq teco-trace (not teco-trace)))
|
|
|
567
|
|
|
568 (teco-define-type-1
|
|
|
569 ?. ; .
|
|
|
570 ;; value is point
|
|
|
571 (setq teco-exp-val1 (point)
|
|
|
572 teco-exp-flag1 t))
|
|
|
573
|
|
|
574 (teco-define-type-1
|
|
|
575 ?z ; z
|
|
|
576 ;; value is point-max
|
|
|
577 (setq teco-exp-val1 (point-max)
|
|
|
578 teco-exp-flag1 t))
|
|
|
579
|
|
|
580 (teco-define-type-1
|
|
|
581 ?b ; b
|
|
|
582 ;; value is point-min
|
|
|
583 (setq teco-exp-val1 (point-min)
|
|
|
584 teco-exp-flag1 t))
|
|
|
585
|
|
|
586 (teco-define-type-1
|
|
|
587 ?h ; h
|
|
|
588 ;; value is b,z
|
|
|
589 (setq teco-exp-val1 (point-max)
|
|
|
590 teco-exp-val2 (point-min)
|
|
|
591 teco-exp-flag1 t
|
|
|
592 teco-exp-flag2 t
|
|
|
593 teco-exp-op 'start))
|
|
|
594
|
|
|
595 (teco-define-type-1
|
|
|
596 ?\^s ; ^s
|
|
|
597 ;; value is - length of last insert, etc.
|
|
|
598 (setq teco-exp-val1 teco-ctrl-s
|
|
|
599 teco-exp-flag1 t))
|
|
|
600
|
|
|
601 (teco-define-type-1
|
|
|
602 ?\^y ; ^y
|
|
|
603 ;; value is .+^S,.
|
|
|
604 (setq teco-exp-val1 (+ (point) teco-ctrl-s)
|
|
|
605 teco-exp-val2 (point)
|
|
|
606 teco-exp-flag1 t
|
|
|
607 teco-exp-flag2 t
|
|
|
608 teco-exp-op 'start))
|
|
|
609
|
|
|
610 (teco-define-type-1
|
|
|
611 ?\( ; \(
|
|
|
612 ;; push expression stack
|
|
|
613 (teco-push-exp-stack)
|
|
|
614 (setq teco-exp-flag1 nil
|
|
|
615 teco-exp-flag2 nil
|
|
|
616 teco-exp-op 'start))
|
|
|
617
|
|
|
618 (teco-define-type-1
|
|
|
619 ?\^p ; ^p
|
|
|
620 (teco-do-ctrl-p))
|
|
|
621
|
|
|
622 (teco-define-type-1
|
|
|
623 ?\C-^ ; ^^
|
|
|
624 ;; get next command character
|
|
|
625 (setq teco-exp-val1 (teco-get-command teco-trace)
|
|
|
626 teco-exp-flag1 t))
|
|
|
627
|
|
|
628
|
|
|
629 ;; Type 2 commands
|
|
|
630 (teco-define-type-2
|
|
|
631 ?+ ; +
|
|
|
632 (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0)
|
|
|
633 teco-exp-flag1 nil
|
|
|
634 teco-exp-op 'add))
|
|
|
635
|
|
|
636 (teco-define-type-2
|
|
|
637 ?- ; -
|
|
|
638 (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0)
|
|
|
639 teco-exp-flag1 nil
|
|
|
640 teco-exp-op 'sub))
|
|
|
641
|
|
|
642 (teco-define-type-2
|
|
|
643 ?* ; *
|
|
|
644 (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0)
|
|
|
645 teco-exp-flag1 nil
|
|
|
646 teco-exp-op 'mult))
|
|
|
647
|
|
|
648 (teco-define-type-2
|
|
|
649 ?/ ; /
|
|
|
650 (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0)
|
|
|
651 teco-exp-flag1 nil
|
|
|
652 teco-exp-op 'div))
|
|
|
653
|
|
|
654 (teco-define-type-2
|
|
|
655 ?& ; &
|
|
|
656 (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0)
|
|
|
657 teco-exp-flag1 nil
|
|
|
658 teco-exp-op 'and))
|
|
|
659
|
|
|
660 (teco-define-type-2
|
|
|
661 ?# ; #
|
|
|
662 (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0)
|
|
|
663 teco-exp-flag1 nil
|
|
|
664 teco-exp-op 'or))
|
|
|
665
|
|
|
666 (teco-define-type-2
|
|
|
667 ?\) ; \)
|
|
|
668 (if (or (not teco-exp-flag1) (not teco-exp-stack))
|
|
|
669 (teco-error "NAP"))
|
|
|
670 (let ((v teco-exp-val1))
|
|
|
671 (teco-pop-exp-stack)
|
|
|
672 (setq teco-exp-val1 v
|
|
|
673 teco-exp-flag1 t)))
|
|
|
674
|
|
|
675 (teco-define-type-2
|
|
|
676 ?, ; ,
|
|
|
677 (if (not teco-exp-flag1)
|
|
|
678 (teco-error "NAC"))
|
|
|
679 (setq teco-exp-val2 teco-exp-val1
|
|
|
680 teco-exp-flag2 t
|
|
|
681 teco-exp-flag1 nil))
|
|
|
682
|
|
|
683 (teco-define-type-2
|
|
|
684 ?\^_ ; ^_
|
|
|
685 (if (not teco-exp-flag1)
|
|
|
686 (teco-error "NAB")
|
|
|
687 (setq teco-exp-val1 (lognot teco-exp-val1))))
|
|
|
688
|
|
|
689 (teco-define-type-2
|
|
|
690 ?\^d ; ^d
|
|
|
691 (setq teco-ctrl-r 10
|
|
|
692 teco-exp-flag1 nil
|
|
|
693 teco-exp-op 'start))
|
|
|
694
|
|
|
695 (teco-define-type-2
|
|
|
696 ?\^o ; ^o
|
|
|
697 (setq teco-ctrl-r 8
|
|
|
698 teco-exp-flag1 nil
|
|
|
699 teco-exp-op 'start))
|
|
|
700
|
|
|
701 (teco-define-type-2
|
|
|
702 ?\^r ; ^r
|
|
|
703 (if teco-colon-flag
|
|
|
704 (progn
|
|
|
705 (recursive-edit)
|
|
|
706 (setq teco-colon-flag nil))
|
|
|
707 (if teco-exp-flag1
|
|
|
708 ;; set radix
|
|
|
709 (progn
|
|
|
710 (if (and (/= teco-exp-val1 8)
|
|
|
711 (/= teco-exp-val1 10)
|
|
|
712 (/= teco-exp-val1 16))
|
|
|
713 (teco-error "IRA"))
|
|
|
714 (setq teco-ctrl-r teco-exp-val1
|
|
|
715 teco-exp-flag1 nil
|
|
|
716 teco-exp-op 'start))
|
|
|
717 ;; get radix
|
|
|
718 (setq teco-exp-val1 teco-ctrl-r
|
|
|
719 teco-exp-flag1 t))))
|
|
|
720
|
|
|
721 (teco-define-type-2
|
|
|
722 ?\^c ; ^c
|
|
|
723 (if (teco-peek-command ?\^c)
|
|
|
724 ;; ^C^C stops execution
|
|
|
725 (throw 'teco-exit nil)
|
|
|
726 (if teco-macro-stack
|
|
|
727 ;; ^C inside macro exits macro
|
|
|
728 (teco-pop-macro-stack)
|
|
|
729 ;; ^C in command stops execution
|
|
|
730 (throw 'teco-exit nil))))
|
|
|
731
|
|
|
732 (teco-define-type-2
|
|
|
733 ?\^x ; ^x
|
|
|
734 ;; set/get search mode flag
|
|
|
735 (teco-set-var 'teco-ctrl-x))
|
|
|
736
|
|
|
737 (teco-define-type-2
|
|
|
738 ?m ; m
|
|
|
739 (let ((macro-name (teco-get-qspec nil
|
|
|
740 (teco-get-command teco-trace))))
|
|
|
741 (teco-push-macro-stack)
|
|
|
742 (setq teco-command-string (aref teco-qreg-text macro-name)
|
|
|
743 teco-command-pointer 0)))
|
|
|
744
|
|
|
745 (teco-define-type-2
|
|
|
746 ?< ; <
|
|
|
747 ;; begin iteration
|
|
|
748 (if (and teco-exp-flag1 (<= teco-exp-val1 0))
|
|
|
749 ;; if this is not to be executed, just skip the
|
|
|
750 ;; intervening stuff
|
|
|
751 (teco-find-enditer)
|
|
|
752 ;; push iteration stack
|
|
|
753 (teco-push-iter-stack teco-command-pointer
|
|
|
754 teco-exp-flag1 teco-exp-val1)
|
|
|
755 ;; consume the argument
|
|
|
756 (setq teco-exp-flag1 nil)))
|
|
|
757
|
|
|
758 (teco-define-type-2
|
|
|
759 ?> ; >
|
|
|
760 ;; end iteration
|
|
|
761 (if (not teco-iteration-stack)
|
|
|
762 (teco-error "BNI"))
|
|
|
763 ;; decrement count and pop conditionally
|
|
|
764 (teco-pop-iter-stack nil)
|
|
|
765 ;; consume arguments
|
|
|
766 (setq teco-exp-flag1 nil
|
|
|
767 teco-exp-flag2 nil
|
|
|
768 teco-exp-op 'start))
|
|
|
769
|
|
|
770 (teco-define-type-2
|
|
|
771 59 ; ;
|
|
|
772 ;; semicolon iteration exit
|
|
|
773 (if (not teco-iteration-stack)
|
|
|
774 (teco-error "SNI"))
|
|
|
775 ;; if exit
|
|
|
776 (if (if (>= (if teco-exp-flag1
|
|
|
777 teco-exp-val1
|
|
|
778 teco-search-result) 0)
|
|
|
779 (not teco-colon-flag)
|
|
|
780 teco-colon-flag)
|
|
|
781 (progn
|
|
|
782 (teco-find-enditer)
|
|
|
783 (teco-pop-iter-stack t)))
|
|
|
784 ;; consume argument and colon
|
|
|
785 (setq teco-exp-flag1 nil
|
|
|
786 teco-colon-flag nil
|
|
|
787 teco-exp-op 'start))
|
|
|
788
|
|
|
789 (teco-define-type-2
|
|
|
790 ?\" ; \"
|
|
|
791 ;; must be an argument
|
|
|
792 (if (not teco-exp-flag1)
|
|
|
793 (teco-error "NAQ"))
|
|
|
794 ;; consume argument
|
|
|
795 (setq teco-exp-flag1 nil
|
|
|
796 teco-exp-op 'start)
|
|
|
797 (let* (;; get the test specification
|
|
|
798 (c (aref teco-mapch-l (teco-get-command teco-trace)))
|
|
|
799 ;; determine whether the test is true
|
|
|
800 (test (cond ((eq c ?a)
|
|
|
801 (/= (logand (aref teco-char-types teco-exp-val1)
|
|
|
802 1) 0))
|
|
|
803 ((eq c ?c)
|
|
|
804 (/= (logand (aref teco-char-types teco-exp-val1)
|
|
|
805 2) 0))
|
|
|
806 ((eq c ?d)
|
|
|
807 (/= (logand (aref teco-char-types teco-exp-val1)
|
|
|
808 4) 0))
|
|
|
809 ((or (eq c ?e) (eq c ?f) (eq c ?u) (eq c ?=))
|
|
|
810 (= teco-exp-val1 0))
|
|
|
811 ((or (eq c ?g) (eq c ?>))
|
|
|
812 (> teco-exp-val1 0))
|
|
|
813 ((or (eq c ?l) (eq c ?s) (eq c ?t) (eq c ?<))
|
|
|
814 (< teco-exp-val1 0))
|
|
|
815 ((eq c ?n)
|
|
|
816 (/= teco-exp-val1 0))
|
|
|
817 ((eq c ?r)
|
|
|
818 (/= (logand (aref teco-char-types teco-exp-val1)
|
|
|
819 8) 0))
|
|
|
820 ((eq c ?v)
|
|
|
821 (/= (logand (aref teco-char-types teco-exp-val1)
|
|
|
822 16) 0))
|
|
|
823 ((eq c ?w)
|
|
|
824 (/= (logand (aref teco-char-types teco-exp-val1)
|
|
|
825 32) 0))
|
|
|
826 (t
|
|
|
827 (teco-error "IQC")))))
|
|
|
828 (if (not test)
|
|
|
829 ;; if the conditional isn't satisfied, read
|
|
|
830 ;; to matching | or '
|
|
|
831 (let ((ll 1)
|
|
|
832 c)
|
|
|
833 (while (> ll 0)
|
|
|
834 (while (progn (setq c (teco-skipto))
|
|
|
835 (and (/= c ?\")
|
|
|
836 (/= c ?|)
|
|
|
837 (/= c ?\')))
|
|
|
838 (if (= c ?\")
|
|
|
839 (setq ll (1+ ll))
|
|
|
840 (if (= c ?\')
|
|
|
841 (setq ll (1- ll))
|
|
|
842 (if (= ll 1)
|
|
|
843 (break))))))))))
|
|
|
844
|
|
|
845 (teco-define-type-2
|
|
|
846 ?' ; '
|
|
|
847 ;; ignore it if executing
|
|
|
848 t)
|
|
|
849
|
|
|
850 (teco-define-type-2
|
|
|
851 ?| ; |
|
|
|
852 (let ((ll 1)
|
|
|
853 c)
|
|
|
854 (while (> ll 0)
|
|
|
855 (while (progn (setq c (teco-skipto))
|
|
|
856 (and (/= c ?\")
|
|
|
857 (/= c ?\')))
|
|
|
858 nil)
|
|
|
859 (if (= c ?\")
|
|
|
860 (setq ll (1+ ll))
|
|
|
861 (setq ll (1- ll))))))
|
|
|
862
|
|
|
863 (teco-define-type-2
|
|
|
864 ?u ; u
|
|
|
865 (if (not teco-exp-flag1)
|
|
|
866 (teco-error "NAU"))
|
|
|
867 (aset teco-qreg-number
|
|
|
868 (teco-get-qspec 0 (teco-get-command teco-trace))
|
|
|
869 teco-exp-val1)
|
|
|
870 (setq teco-exp-flag1 teco-exp-flag2 ; command's value is second arg
|
|
|
871 teco-exp-val1 teco-exp-val2
|
|
|
872 teco-exp-flag2 nil
|
|
|
873 teco-exp-op 'start))
|
|
|
874
|
|
|
875 (teco-define-type-2
|
|
|
876 ?q ; q
|
|
|
877 ;; Qn is numeric val, :Qn is # of chars, mQn is mth char
|
|
|
878 (let ((mm (teco-get-qspec (or teco-colon-flag teco-exp-flag1)
|
|
|
879 (teco-get-command teco-trace))))
|
|
|
880 (if (not teco-exp-flag1)
|
|
|
881 (setq teco-exp-val1 (if teco-colon-flag
|
|
|
882 ;; :Qn
|
|
|
883 (length (aref teco-qreg-text mm))
|
|
|
884 ;; Qn
|
|
|
885 (aref teco-qreg-number mm))
|
|
|
886 teco-exp-flag1 t)
|
|
|
887 ;; mQn
|
|
|
888 (let ((v (aref teco-qreg-text mm)))
|
|
|
889 (setq teco-exp-val1 (condition-case nil
|
|
|
890 (aref v teco-exp-val1)
|
|
|
891 (error -1))
|
|
|
892 teco-exp-op 'start)))
|
|
|
893 (setq teco-colon-flag nil)))
|
|
|
894
|
|
|
895 (teco-define-type-2
|
|
|
896 ?% ; %
|
|
|
897 (let* ((mm (teco-get-qspec nil (teco-get-command teco-trace)))
|
|
|
898 (v (+ (aref teco-qreg-number mm) (teco-get-value 1))))
|
|
|
899 (aset teco-qreg-number mm v)
|
|
|
900 (setq teco-exp-val1 v
|
|
|
901 teco-exp-flag1 t)))
|
|
|
902
|
|
|
903 (teco-define-type-2
|
|
|
904 ?c ; c
|
|
|
905 (let ((p (+ (point) (teco-get-value 1))))
|
|
|
906 (if (or (< p (point-min)) (> p (point-max)))
|
|
|
907 (teco-error "POP")
|
|
|
908 (goto-char p)
|
|
|
909 (setq teco-exp-flag2 nil))))
|
|
|
910
|
|
|
911 (teco-define-type-2
|
|
|
912 ?r ; r
|
|
|
913 (let ((p (- (point) (teco-get-value 1))))
|
|
|
914 (if (or (< p (point-min)) (> p (point-max)))
|
|
|
915 (teco-error "POP")
|
|
|
916 (goto-char p)
|
|
|
917 (setq teco-exp-flag2 nil))))
|
|
|
918
|
|
|
919 (teco-define-type-2
|
|
|
920 ?j ; j
|
|
|
921 (let ((p (teco-get-value (point-min))))
|
|
|
922 (if (or (< p (point-min)) (> p (point-max)))
|
|
|
923 (teco-error "POP")
|
|
|
924 (goto-char p)
|
|
|
925 (setq teco-exp-flag2 nil))))
|
|
|
926
|
|
|
927 (teco-define-type-2
|
|
|
928 ?l ; l
|
|
|
929 ;; move forward by lines
|
|
|
930 (forward-char (teco-lines (teco-get-value 1))))
|
|
|
931
|
|
|
932 (teco-define-type-2
|
|
|
933 ?\C-q ; ^q
|
|
|
934 ;; number of characters until the nth line feed
|
|
|
935 (setq teco-exp-val1 (teco-lines (teco-get-value 1))
|
|
|
936 teco-exp-flag1 t))
|
|
|
937
|
|
|
938 (teco-define-type-2
|
|
|
939 ?= ; =
|
|
|
940 ;; print numeric value
|
|
|
941 (if (not teco-exp-flag1)
|
|
|
942 (teco-error "NAE"))
|
|
|
943 (teco-output (format
|
|
|
944 (if (teco-peek-command ?=)
|
|
|
945 ;; at least one more =
|
|
|
946 (progn
|
|
|
947 ;; read past it
|
|
|
948 (teco-get-command teco-trace)
|
|
|
949 (if (teco-peek-command ?=)
|
|
|
950 ;; another?
|
|
|
951 (progn
|
|
|
952 ;; read it too
|
|
|
953 (teco-get-command teco-trace)
|
|
|
954 ;; print in hex
|
|
|
955 "%x")
|
|
|
956 ;; print in octal
|
|
|
957 "%o"))
|
|
|
958 ;; print in decimal
|
|
|
959 "%d")
|
|
|
960 teco-exp-val1))
|
|
|
961 ;; add newline if no colon
|
|
|
962 (if (not teco-colon-flag)
|
|
|
963 (teco-output ?\n))
|
|
|
964 ;; absorb argument, etc.
|
|
|
965 (setq teco-exp-flag1 nil
|
|
|
966 teco-exp-flag2 nil
|
|
|
967 teco-colon-flag nil
|
|
|
968 teco-exp-op 'start))
|
|
|
969
|
|
|
970 (teco-define-type-2
|
|
|
971 ?\t ; TAB
|
|
|
972 (if exp-flag1
|
|
|
973 (teco-error "IIA"))
|
|
|
974 (let ((text (teco-get-text-arg)))
|
|
|
975 (insert ?\t text)
|
|
|
976 (setq teco-ctrl-s (1+ (length text))))
|
|
|
977 ;; clear arguments
|
|
|
978 (setq teco-colon-flag nil
|
|
|
979 teco-exp-flag1 nil
|
|
|
980 teco-exp-flag2 nil))
|
|
|
981
|
|
|
982 (teco-define-type-2
|
|
|
983 ?i ; i
|
|
|
984 (let ((text (teco-get-text-arg)))
|
|
|
985 (if teco-exp-flag1
|
|
|
986 ;; if a nI$ command
|
|
|
987 (progn
|
|
|
988 ;; text argument must be null
|
|
|
989 (or (string-equal text "") (teco-error "IIA"))
|
|
|
990 ;; insert the character
|
|
|
991 (insert teco-exp-val1)
|
|
|
992 (setq teco-ctrl-s 1)
|
|
|
993 ;; consume argument
|
|
|
994 (setq teco-exp-op 'start))
|
|
|
995 ;; otherwise, insert the text
|
|
|
996 (insert text)
|
|
|
997 (setq teco-ctrl-s (length text)))
|
|
|
998 ;; clear arguments
|
|
|
999 (setq teco-colon-flag nil
|
|
|
1000 teco-exp-flag1 nil
|
|
|
1001 teco-exp-flag2 nil)))
|
|
|
1002
|
|
|
1003 (teco-define-type-2
|
|
|
1004 ?t ; t
|
|
|
1005 (let ((args (teco-line-args nil)))
|
|
|
1006 (teco-output (buffer-substring (car args) (cdr args)))))
|
|
|
1007
|
|
|
1008 (teco-define-type-2
|
|
|
1009 ?v ; v
|
|
|
1010 (let ((ll (teco-get-value 1)))
|
|
|
1011 (teco-output (buffer-substring (+ (point) (teco-lines (- 1 ll)))
|
|
|
1012 (+ (point) (teco-lines ll))))))
|
|
|
1013
|
|
|
1014 (teco-define-type-2
|
|
|
1015 ?\C-a ; ^a
|
|
|
1016 (teco-output (teco-get-text-arg nil ?\C-a))
|
|
|
1017 (setq teco-at-flag nil
|
|
|
1018 teco-colon-flag nil
|
|
|
1019 teco-exp-flag1 nil
|
|
|
1020 teco-exp-flag2 nil
|
|
|
1021 teco-exp-op 'start))
|
|
|
1022
|
|
|
1023 (teco-define-type-2
|
|
|
1024 ?d ; d
|
|
|
1025 (if (not teco-exp-flag2)
|
|
|
1026 ;; if only one argument
|
|
|
1027 (delete-char (teco-get-value 1))
|
|
|
1028 ;; if two arguments, treat as n,mK
|
|
|
1029 (let ((ll (teco-line-args 1)))
|
|
|
1030 (delete-region (car ll) (cdr ll)))))
|
|
|
1031
|
|
|
1032 (teco-define-type-2
|
|
|
1033 ?k ; k
|
|
|
1034 (let ((ll (teco-line-args 1)))
|
|
|
1035 (delete-region (car ll) (cdr ll))))
|
|
|
1036
|
|
|
1037 (teco-define-type-2
|
|
|
1038 ?\C-u ; ^u
|
|
|
1039 (let* ((mm (teco-get-qspec nil (teco-get-command teco-trace)))
|
|
|
1040 (text-arg (teco-get-text-arg))
|
|
|
1041 (text (if (not teco-exp-flag1)
|
|
|
1042 text-arg
|
|
|
1043 (if (string-equal text-arg "")
|
|
|
1044 (char-to-string teco-exp-val1)
|
|
|
1045 (teco-error "IIA")))))
|
|
|
1046 ;; if :, append to the register
|
|
|
1047 (aset teco-qreg-text mm (if teco-colon-flag
|
|
|
1048 (concat (aref teco-qreg-text mm) text)
|
|
|
1049 text))
|
|
|
1050 ;; clear various flags
|
|
|
1051 (setq teco-exp-flag1 nil
|
|
|
1052 teco-at-flag nil
|
|
|
1053 teco-colon-flag nil
|
|
|
1054 teco-exp-flag1 nil)))
|
|
|
1055
|
|
|
1056 (teco-define-type-2
|
|
|
1057 ?x ; x
|
|
|
1058 (let* ((mm (teco-get-qspec nil (teco-get-command teco-trace)))
|
|
|
1059 (args (teco-line-args 0))
|
|
|
1060 (text (buffer-substring (car args) (cdr args))))
|
|
|
1061 ;; if :, append to the register
|
|
|
1062 (aset teco-qreg-text mm (if teco-colon-flag
|
|
|
1063 (concat (aref teco-qreg-text mm) text)
|
|
|
1064 text))
|
|
|
1065 ;; clear various flags
|
|
|
1066 (setq teco-exp-flag1 nil
|
|
|
1067 teco-at-flag nil
|
|
|
1068 teco-colon-flag nil
|
|
|
1069 teco-exp-flag1 nil)))
|
|
|
1070
|
|
|
1071 (teco-define-type-2
|
|
|
1072 ?g ; g
|
|
|
1073 (let ((mm (teco-get-qspec t (teco-get-command teco-trace))))
|
|
|
1074 (if teco-colon-flag
|
|
|
1075 (teco-output (aref teco-qreg-text mm))
|
|
|
1076 (insert (aref teco-qreg-text mm)))
|
|
|
1077 (setq teco-colon-flag nil)))
|
|
|
1078
|
|
|
1079 (teco-define-type-2
|
|
|
1080 ?\[ ; \[
|
|
|
1081 (let ((mm (teco-get-qspec t (teco-get-command teco-trace))))
|
|
|
1082 (setq teco-qreg-stack
|
|
|
1083 (cons (cons (aref teco-qreg-text mm)
|
|
|
1084 (aref teco-qreg-number mm))
|
|
|
1085 teco-qreg-stack))))
|
|
|
1086
|
|
|
1087 (teco-define-type-2
|
|
|
1088 ?\] ; \]
|
|
|
1089 (let ((mm (teco-get-qspec t (teco-get-command teco-trace))))
|
|
|
1090 (if teco-colon-flag
|
|
|
1091 (setq teco-exp-flag1 t
|
|
|
1092 teco-exp-val1 (if teco-qreg-stack -1 0))
|
|
|
1093 (if teco-qreg-stack
|
|
|
1094 (let ((pop (car teco-qreg-stack)))
|
|
|
1095 (aset teco-qreg-text mm (car pop))
|
|
|
1096 (aset teco-qreg-number mm (cdr pop))
|
|
|
1097 (setq teco-qreg-stack (cdr teco-qreg-stack)))
|
|
|
1098 (teco-error "CPQ")))
|
|
|
1099 (setq teco-colon-flag nil)))
|
|
|
1100
|
|
|
1101 (teco-define-type-2
|
|
|
1102 ?\\ ; \
|
|
|
1103 (if (not teco-exp-flag1)
|
|
|
1104 ;; no argument; read number
|
|
|
1105 (let ((p (point))
|
|
|
1106 (sign +1)
|
|
|
1107 (n 0)
|
|
|
1108 c)
|
|
|
1109 (setq c (char-after p))
|
|
|
1110 (if c
|
|
|
1111 (if (= c ?+)
|
|
|
1112 (setq p (1+ p))
|
|
|
1113 (if (= c ?-)
|
|
|
1114 (setq p (1+ p)
|
|
|
1115 sign -1))))
|
|
|
1116 (cond
|
|
|
1117 ((= teco-ctrl-r 8)
|
|
|
1118 (while (progn
|
|
|
1119 (setq c (char-after p))
|
|
|
1120 (and c (>= c ?0) (<= c ?7)))
|
|
|
1121 (setq p (1+ p)
|
|
|
1122 n (+ c -48 (* n 8)))))
|
|
|
1123 ((= teco-ctrl-r 10)
|
|
|
1124 (while (progn
|
|
|
1125 (setq c (char-after p))
|
|
|
1126 (and c (>= c ?0) (<= c ?9)))
|
|
|
1127 (setq p (1+ p)
|
|
|
1128 n (+ c -48 (* n 10)))))
|
|
|
1129 (t
|
|
|
1130 (while (progn
|
|
|
1131 (setq c (char-after p))
|
|
|
1132 (and c
|
|
|
1133 (or
|
|
|
1134 (and (>= c ?0) (<= c ?9))
|
|
|
1135 (and (>= c ?a) (<= c ?f))
|
|
|
1136 (and (>= c ?A) (<= c ?F)))))
|
|
|
1137 (setq p (1+ p)
|
|
|
1138 n (+ c (if (> c ?F)
|
|
|
1139 ;; convert 'a' to 10
|
|
|
1140 -87
|
|
|
1141 (if (> c ?9)
|
|
|
1142 ;; convert 'A' to 10
|
|
|
1143 -55
|
|
|
1144 ;; convert '0' to 0
|
|
|
1145 -48))
|
|
|
1146 (* n 16))))))
|
|
|
1147 (setq teco-exp-val1 (* n sign)
|
|
|
1148 teco-exp-flag1 t
|
|
|
1149 teco-ctrl-s (- (point) p)))
|
|
|
1150 ;; argument: insert it as a digit string
|
|
|
1151 (insert (format (cond
|
|
|
1152 ((= teco-ctrl-r 8) "%o")
|
|
|
1153 ((= teco-ctrl-r 10) "%d")
|
|
|
1154 (t "%x"))
|
|
|
1155 teco-exp-val1))
|
|
|
1156 (setq teco-exp-flag1 nil
|
|
|
1157 teco-exp-op 'start)))
|
|
|
1158
|
|
|
1159 (teco-define-type-2
|
|
|
1160 ?\C-t ; ^t
|
|
|
1161 (if teco-exp-flag1
|
|
|
1162 ;; type a character
|
|
|
1163 (progn
|
|
|
1164 (teco-output teco-exp-val1)
|
|
|
1165 (setq teco-exp-flag1 nil))
|
|
|
1166 ;; input a character
|
|
|
1167 (let* ((echo-keystrokes 0)
|
|
|
1168 (c (read-char)))
|
|
|
1169 (teco-output c)
|
|
|
1170 (setq teco-exp-val1 c
|
|
|
1171 teco-exp-flag1 t))))
|
|
|
1172
|
|
|
1173 (teco-define-type-2
|
|
|
1174 ?s ; s
|
|
|
1175 (let ((arg (teco-get-text-arg))
|
|
|
1176 (count (if teco-exp-flag1 teco-expr-val1 1))
|
|
|
1177 regexp)
|
|
|
1178 (if (not (string-equal arg ""))
|
|
|
1179 (setq regexp (teco-parse-search-string arg)
|
|
|
1180 teco-last-search-string arg
|
|
|
1181 teco-last-search-regexp regexp)
|
|
|
1182 (setq regexp (teco-last-search-regexp)
|
|
|
1183 arg teco-last-search-string))
|
|
|
1184 (let ((p (point))
|
|
|
1185 (result (cond
|
|
|
1186 ((> count 0)
|
|
|
1187 (re-search-forward regexp nil t count))
|
|
|
1188 ((< count 0)
|
|
|
1189 (re-search-backward regexp nil t count))
|
|
|
1190 (t
|
|
|
1191 ;; 0s always is successful
|
|
|
1192 t))))
|
|
|
1193 ;; if ::s, restore point
|
|
|
1194 (if (eq teco-colon-flag 2)
|
|
|
1195 (goto-char p))
|
|
|
1196 ;; if no real or implied colon, error if not found
|
|
|
1197 (if (and (not result)
|
|
|
1198 (not teco-colon-flag)
|
|
|
1199 (/= (teco-peekcmdc) 34))
|
|
|
1200 (teco-error "SRH"))
|
|
|
1201 ;; set return results
|
|
|
1202 (setq teco-exp-flag2 nil
|
|
|
1203 teco-colon-flag nil
|
|
|
1204 teco-at-flag nil
|
|
|
1205 teco-exp-op 'start)
|
|
|
1206 (if teco-colon-flag
|
|
|
1207 (setq teco-exp-flag1 t
|
|
|
1208 teco-exp-val1 (if result -1 0))
|
|
|
1209 (setq teco-exp-flag1 nil)))))
|
|
|
1210
|
|
|
1211 (defun teco-parse-search-string (s)
|
|
|
1212 (let ((i 0)
|
|
|
1213 (l (length s))
|
|
|
1214 (r "")
|
|
|
1215 c)
|
|
|
1216 (while (< i l)
|
|
|
1217 (setq r (concat r (teco-parse-search-string-1))))
|
|
|
1218 r))
|
|
|
1219
|
|
|
1220 (defun teco-parse-search-string-1 ()
|
|
|
1221 (if (>= i l)
|
|
|
1222 (teco-error "ISS"))
|
|
|
1223 (setq c (aref s i))
|
|
|
1224 (setq i (1+ i))
|
|
|
1225 (cond
|
|
|
1226 ((eq c ?\C-e) ; ^E - special match characters
|
|
|
1227 (teco-parse-search-string-e))
|
|
|
1228 ((eq c ?\C-n) ; ^Nx - match all but x
|
|
|
1229 (teco-parse-search-string-n))
|
|
|
1230 ((eq c ?\C-q) ; ^Qx - use x literally
|
|
|
1231 (teco-parse-search-string-q))
|
|
|
1232 ((eq c ?\C-s) ; ^S - match separator chars
|
|
|
1233 "[^A-Za-z0-9]")
|
|
|
1234 ((eq c ?\C-x) ; ^X - match any character
|
|
|
1235 "[\000-\377]")
|
|
|
1236 (t ; ordinary character
|
|
|
1237 (teco-parse-search-string-char c))))
|
|
|
1238
|
|
|
1239 (defun teco-parse-search-string-char (c)
|
|
|
1240 (regexp-quote (char-to-string c)))
|
|
|
1241
|
|
|
1242 (defun teco-parse-search-string-q ()
|
|
|
1243 (if (>= i l)
|
|
|
1244 (teco-error "ISS"))
|
|
|
1245 (setq c (aref s i))
|
|
|
1246 (setq i (1+ i))
|
|
|
1247 (teco-parse-search-string-char c))
|
|
|
1248
|
|
|
1249 (defun teco-parse-search-string-e ()
|
|
|
1250 (if (>= i l)
|
|
|
1251 (teco-error "ISS"))
|
|
|
1252 (setq c (aref s i))
|
|
|
1253 (setq i (1+ i))
|
|
|
1254 (cond
|
|
|
1255 ((or (eq c ?a) (eq c ?A)) ; ^EA - match alphabetics
|
|
|
1256 "[A-Za-z]")
|
|
|
1257 ((or (eq c ?c) (eq c ?C)) ; ^EC - match symbol constituents
|
|
|
1258 "[A-Za-z.$]")
|
|
|
1259 ((or (eq c ?d) (eq c ?D)) ; ^ED - match numerics
|
|
|
1260 "[0-9]")
|
|
|
1261 ((eq c ?g) ; ^EGq - match any char in q-reg
|
|
|
1262 (teco-parse-search-string-e-g))
|
|
|
1263 ((or (eq c ?l) (eq c ?L)) ; ^EL - match line terminators
|
|
|
1264 "[\012\013\014]")
|
|
|
1265 ((eq c ?q) ; ^EQq - use contents of q-reg
|
|
|
1266 (teco-parse-search-string-e-q))
|
|
|
1267 ((eq c ?r) ; ^ER - match alphanumerics
|
|
|
1268 "[A-Za-z0-9]")
|
|
|
1269 ((eq c ?s) ; ^ES - match non-null space/tab seq
|
|
|
1270 "[ \t]+")
|
|
|
1271 ((eq c ?v) ; ^EV - match lower case alphabetic
|
|
|
1272 "[a-z]")
|
|
|
1273 ((eq c ?w) ; ^EW - match upper case alphabetic
|
|
|
1274 "[A-Z]")
|
|
|
1275 ((eq c ?x) ; ^EX - match any character
|
|
|
1276 "[\000-\377]")
|
|
|
1277 (t
|
|
|
1278 (teco-error "ISS"))))
|
|
|
1279
|
|
|
1280 (defun teco-parse-search-string-e-q ()
|
|
|
1281 (if (>= i l)
|
|
|
1282 (teco-error "ISS"))
|
|
|
1283 (setq c (aref s i))
|
|
|
1284 (setq i (1+ i))
|
|
|
1285 (regexp-quote (aref reco:q-reg-text c)))
|
|
|
1286
|
|
|
1287 (defun teco-parse-search-string-e-g ()
|
|
|
1288 (if (>= i l)
|
|
|
1289 (teco-error "ISS"))
|
|
|
1290 (setq c (aref s i))
|
|
|
1291 (setq i (1+ i))
|
|
|
1292 (let* ((q (aref teco-qreg-text c))
|
|
|
1293 (len (length q))
|
|
|
1294 (null (= len 0))
|
|
|
1295 (one-char (= len 1))
|
|
|
1296 (dash-present (string-match "-" q))
|
|
|
1297 (caret-present (string-match "\\^" q))
|
|
|
1298 (outbracket-present (string-match "]" q))
|
|
|
1299 p)
|
|
|
1300 (cond
|
|
|
1301 (null
|
|
|
1302 "[^\000-\377]")
|
|
|
1303 (one-char
|
|
|
1304 (teco-parse-search-string-char c))
|
|
|
1305 (t
|
|
|
1306 (while (setq p (string-match "^]\\^"))
|
|
|
1307 (setq q (concat (substring q 1 p) (substring q (1+ p)))))
|
|
|
1308 (concat
|
|
|
1309 "["
|
|
|
1310 (if outbracket-present "]" "")
|
|
|
1311 (if dash-present "---" "")
|
|
|
1312 q
|
|
|
1313 (if caret-present "^" ""))))))
|
|
|
1314
|
|
|
1315 (defun teco-parse-search-string-n ()
|
|
|
1316 (let ((p (teco-parse-search-string-1)))
|
|
|
1317 (cond
|
|
|
1318 ((= (aref p 0) ?\[)
|
|
|
1319 (if (= (aref p 1) ?^)
|
|
|
1320 ;; complement character set
|
|
|
1321 (if (= (length p) 4)
|
|
|
1322 ;; complement of one character
|
|
|
1323 (teco-parse-search-string-char (aref p 2))
|
|
|
1324 ;; complement of more than one character
|
|
|
1325 (concat "[" (substring p 2)))
|
|
|
1326 ;; character set - invert it
|
|
|
1327 (concat "[^" (substring p 1))))
|
|
|
1328 ((= (aref p 0) ?\\)
|
|
|
1329 ;; single quoted character
|
|
|
1330 (concat "[^" (substring p 1) "]"))
|
|
|
1331 (t
|
|
|
1332 ;; single character
|
|
|
1333 (if (string-equal p "-")
|
|
|
1334 "[^---]"
|
|
|
1335 (concat "[^" p "]"))))))
|
|
|
1336
|
|
|
1337 (teco-define-type-2
|
|
|
1338 ?o ; o
|
|
|
1339 (let ((label (teco-get-text-arg))
|
|
|
1340 (index (and teco-exp-flag1 teco-exp-val1)))
|
|
|
1341 (setq teco-exp-flag1 nil)
|
|
|
1342 ;; handle computed goto by extracting the proper label
|
|
|
1343 (if index
|
|
|
1344 (if (< index 0)
|
|
|
1345 ;; argument < 0 is a noop
|
|
|
1346 (setq label "")
|
|
|
1347 ;; otherwise, find the n-th label (0-origin)
|
|
|
1348 (setq label (concat label ","))
|
|
|
1349 (let ((p 0))
|
|
|
1350 (while (and (> index 0)
|
|
|
1351 (setq p (string-match "," label p))
|
|
|
1352 (setq p (1+ p)))
|
|
|
1353 (setq index (1- index)))
|
|
|
1354 (setq q (string-match "," label p))
|
|
|
1355 (setq label (substring label p q)))))
|
|
|
1356 ;; if the label is non-null, find the correct label
|
|
|
1357 ;; start from beginning of iteration or macro, and look for tag
|
|
|
1358 (setq teco-command-pointer
|
|
|
1359 (if teco-iteration-stack
|
|
|
1360 ;; if in iteration, start at beginning of iteration
|
|
|
1361 (aref (car teco-iteration-stack) 0)
|
|
|
1362 ;; if not in iteration, start at beginning of command or macro
|
|
|
1363 0))
|
|
|
1364 ;; search for tag
|
|
|
1365 (catch 'label
|
|
|
1366 (let ((level 0)
|
|
|
1367 c p l)
|
|
|
1368 ;; look for interesting things, including !
|
|
|
1369 (while t
|
|
|
1370 (setq c (teco-skipto t))
|
|
|
1371 (cond
|
|
|
1372 ((= c ?<) ; start of iteration
|
|
|
1373 (setq level (1+ level)))
|
|
|
1374 ((= c ?>) ; end of iteration
|
|
|
1375 (if (= level 0)
|
|
|
1376 (teco-pop-iter-stack t)
|
|
|
1377 (setq level (1- level))))
|
|
|
1378 ((= c ?!) ; start of tag
|
|
|
1379 (setq p (string-match "!" teco-command-string teco-command-pointer))
|
|
|
1380 (if (and p
|
|
|
1381 (string-equal label (substring teco-command-string
|
|
|
1382 teco-command-pointer
|
|
|
1383 p)))
|
|
|
1384 (progn
|
|
|
1385 (setq teco-command-pointer (1+ p))
|
|
|
1386 (throw 'label nil))))))))))
|
|
|
1387
|
|
|
1388 (teco-define-type-2
|
|
|
1389 ?a ; :a
|
|
|
1390 ;; 'a' must be used as ':a'
|
|
|
1391 (if (and teco-exp-flag1 teco-colon-flag)
|
|
|
1392 (let ((char (+ (point) teco-exp-val1)))
|
|
|
1393 (setq teco-exp-val1
|
|
|
1394 (if (and (>= char (point-min))
|
|
|
1395 (< char (point-max)))
|
|
|
1396 (char-after char)
|
|
|
1397 -1)
|
|
|
1398 teco-colon-flag nil))
|
|
|
1399 (teco-error "ILL")))
|
|
|
1400
|
|
|
1401
|
|
|
1402 ;; Routines to get next character from command buffer
|
|
|
1403 ;; getcmdc0, when reading beyond command string, pops
|
|
|
1404 ;; macro stack and continues.
|
|
|
1405 ;; getcmdc, in similar circumstances, reports an error.
|
|
|
1406 ;; If pushcmdc() has returned any chars, read them first
|
|
|
1407 ;; routines type characters as read, if argument != 0.
|
|
|
1408
|
|
|
1409 (defun teco-get-command0 (trace)
|
|
|
1410 ;; get the next character
|
|
|
1411 (let (char)
|
|
|
1412 (while (not (condition-case nil
|
|
|
1413 (setq char (aref teco-command-string teco-command-pointer))
|
|
|
1414 ;; if we've exhausted the string, pop the macro stack
|
|
|
1415 ;; if we exhaust the macro stack, exit
|
|
|
1416 (error (teco-pop-macro-stack)
|
|
|
1417 nil))))
|
|
|
1418 ;; bump the command pointer
|
|
|
1419 (setq teco-command-pointer (1+ teco-command-pointer))
|
|
|
1420 ;; trace, if requested
|
|
|
1421 (and trace (teco-trace-type char))
|
|
|
1422 ;; return the character
|
|
|
1423 char))
|
|
|
1424
|
|
|
1425 ;; while (cptr.dot >= cptr.z) /* if at end of this level, pop macro stack
|
|
|
1426 ;; {
|
|
|
1427 ;; if (--msp < &mstack[0]) /* pop stack; if top level
|
|
|
1428 ;; {
|
|
|
1429 ;; msp = &mstack[0]; /* restore stack pointer
|
|
|
1430 ;; cmdc = ESC; /* return an ESC (ignored)
|
|
|
1431 ;; exitflag = 1; /* set to terminate execution
|
|
|
1432 ;; return(cmdc); /* exit "while" and return
|
|
|
1433 ;; }
|
|
|
1434 ;; }
|
|
|
1435 ;; cmdc = cptr.p->ch[cptr.c++]; /* get char
|
|
|
1436 ;; ++cptr.dot; /* increment character count
|
|
|
1437 ;; if (trace) type_char(cmdc); /* trace
|
|
|
1438 ;; if (cptr.c > CELLSIZE-1) /* and chain if need be
|
|
|
1439 ;; {
|
|
|
1440 ;; cptr.p = cptr.p->f;
|
|
|
1441 ;; cptr.c = 0;
|
|
|
1442 ;; }
|
|
|
1443 ;; return(cmdc);
|
|
|
1444 ;; }
|
|
|
1445
|
|
|
1446
|
|
|
1447 (defun teco-get-command (trace)
|
|
|
1448 ;; get the next character
|
|
|
1449 (let ((char (condition-case nil
|
|
|
1450 (aref teco-command-string teco-command-pointer)
|
|
|
1451 ;; if we've exhausted the string, give error
|
|
|
1452 (error
|
|
|
1453 (teco-error (if teco-macro-stack "UTM" "UTC"))))))
|
|
|
1454 ;; bump the command pointer
|
|
|
1455 (setq teco-command-pointer (1+ teco-command-pointer))
|
|
|
1456 ;; trace, if requested
|
|
|
1457 (and trace (teco-trace-type char))
|
|
|
1458 ;; return the character
|
|
|
1459 char))
|
|
|
1460
|
|
|
1461 ;; char getcmdc(trace)
|
|
|
1462 ;; {
|
|
|
1463 ;; if (cptr.dot++ >= cptr.z) ERROR((msp <= &mstack[0]) ? E_UTC : E_UTM);
|
|
|
1464 ;; else
|
|
|
1465 ;; {
|
|
|
1466 ;; cmdc = cptr.p->ch[cptr.c++]; /* get char
|
|
|
1467 ;; if (trace) type_char(cmdc); /* trace
|
|
|
1468 ;; if (cptr.c > CELLSIZE-1) /* and chain if need be
|
|
|
1469 ;; {
|
|
|
1470 ;; cptr.p = cptr.p->f;
|
|
|
1471 ;; cptr.c = 0;
|
|
|
1472 ;; }
|
|
|
1473 ;; }
|
|
|
1474 ;; return(cmdc);
|
|
|
1475 ;; }
|
|
|
1476
|
|
|
1477
|
|
|
1478 ;; peek at next char in command string, return 1 if it is equal
|
|
|
1479 ;; (case independent) to argument
|
|
|
1480
|
|
|
1481 (defun teco-peek-command (arg)
|
|
|
1482 (condition-case nil
|
|
|
1483 (eq (aref teco-mapch-l (aref teco-command-string teco-command-pointer))
|
|
|
1484 (aref teco-mapch-l arg))
|
|
|
1485 (error nil)))
|
|
|
1486
|
|
|
1487 ;; int peekcmdc(arg)
|
|
|
1488 ;; char arg;
|
|
|
1489 ;; {
|
|
|
1490 ;; return(((cptr.dot < cptr.z) && (mapch_l[cptr.p->ch[cptr.c]] == mapch_l[arg])) ? 1 : 0);
|
|
|
1491 ;; }
|
|
|
1492
|
|
|
1493 (defun teco-get-text-arg (&optional term-char default-term-char)
|
|
|
1494 ;; figure out what the terminating character is
|
|
|
1495 (setq teco-term-char (or term-char
|
|
|
1496 (if teco-at-flag
|
|
|
1497 (teco-get-command teco-trace)
|
|
|
1498 (or default-term-char
|
|
|
1499 ?\e)))
|
|
|
1500 teco-at_flag nil)
|
|
|
1501 (let ((s "")
|
|
|
1502 c)
|
|
|
1503 (while (progn
|
|
|
1504 (setq c (teco-get-command teco-trace))
|
|
|
1505 (/= c teco-term-char))
|
|
|
1506 (setq s (concat s (char-to-string c))))
|
|
|
1507 s))
|
|
|
1508
|
|
|
1509
|
|
|
1510 ;; Routines to manipulate the stacks
|
|
|
1511
|
|
|
1512 ;; Pop the macro stack. Throw to 'teco-exit' if the stack is empty.
|
|
|
1513 (defun teco-pop-macro-stack ()
|
|
|
1514 (if teco-macro-stack
|
|
|
1515 (let ((frame (car teco-macro-stack)))
|
|
|
1516 (setq teco-macro-stack (cdr teco-macro-stack)
|
|
|
1517 teco-command-string (aref frame 0)
|
|
|
1518 teco-command-pointer (aref frame 1)
|
|
|
1519 teco-exec-flags (aref frame 2)
|
|
|
1520 teco-iteration-stack (aref frame 3)
|
|
|
1521 teco-cond-stack (aref frame 4)))
|
|
|
1522 (throw 'teco-exit nil)))
|
|
|
1523
|
|
|
1524 ;; Push the macro stack.
|
|
|
1525 (defun teco-push-macro-stack ()
|
|
|
1526 (setq teco-macro-stack
|
|
|
1527 (cons (vector teco-command-string
|
|
|
1528 teco-command-pointer
|
|
|
1529 teco-exec-flags
|
|
|
1530 teco-iteration-stack
|
|
|
1531 teco-cond-stack)
|
|
|
1532 teco-macro-stack)))
|
|
|
1533
|
|
|
1534 ;; Pop the expression stack.
|
|
|
1535 (defun teco-pop-exp-stack ()
|
|
|
1536 (let ((frame (car teco-exp-stack)))
|
|
|
1537 (setq teco-exp-stack (cdr teco-exp-stack)
|
|
|
1538 teco-exp-val1 (aref frame 0)
|
|
|
1539 teco-exp-flag1 (aref frame 1)
|
|
|
1540 teco-exp-val2 (aref frame 2)
|
|
|
1541 teco-exp-flag2 (aref frame 3)
|
|
|
1542 teco-exp-exp (aref frame 4)
|
|
|
1543 teco-exp-op (aref frame 5))))
|
|
|
1544
|
|
|
1545 ;; Push the expression stack.
|
|
|
1546 (defun teco-push-exp-stack ()
|
|
|
1547 (setq teco-exp-stack
|
|
|
1548 (cons (vector teco-exp-val1
|
|
|
1549 teco-exp-flag1
|
|
|
1550 teco-exp-val2
|
|
|
1551 teco-exp-flag2
|
|
|
1552 teco-exp-exp
|
|
|
1553 teco-exp-op)
|
|
|
1554 teco-exp-stack)))
|
|
|
1555
|
|
|
1556 ;; Pop the iteration stack
|
|
|
1557 ;; if arg t, exit unconditionally
|
|
|
1558 ;; else check exit conditions and exit or reiterate
|
|
|
1559 (defun teco-pop-iter-stack (arg)
|
|
|
1560 (let ((frame (car teco-iteration-stack)))
|
|
|
1561 (if (or arg
|
|
|
1562 (not (aref frame 1))
|
|
|
1563 ;; test against 1, since one iteration has already been done
|
|
|
1564 (<= (aref frame 2) 1))
|
|
|
1565 ;; exit iteration
|
|
|
1566 (setq teco-iteration-stack (cdr teco-iteration-stack))
|
|
|
1567 ;; continue with iteration
|
|
|
1568 ;; decrement count
|
|
|
1569 (aset frame 2 (1- (aref frame 2)))
|
|
|
1570 ;; reset command pointer
|
|
|
1571 (setq teco-command-pointer (aref frame 0)))))
|
|
|
1572
|
|
|
1573 ;; Push the iteration stack
|
|
|
1574 (defun teco-push-iter-stack (pointer flag count)
|
|
|
1575 (setq teco-iteration-stack
|
|
|
1576 (cons (vector pointer
|
|
|
1577 flag
|
|
|
1578 count)
|
|
|
1579 teco-iteration-stack)))
|
|
|
1580
|
|
|
1581 (defun teco-find-enditer ()
|
|
|
1582 (let ((icnt 1)
|
|
|
1583 c)
|
|
|
1584 (while (> icnt 0)
|
|
|
1585 (while (progn (setq c (teco-skipto))
|
|
|
1586 (and (/= c ?<)
|
|
|
1587 (/= c ?>)))
|
|
|
1588 (if (= c ?<)
|
|
|
1589 (setq icnt (1+ icnt))
|
|
|
1590 (setq icnt (1- icnt)))))))
|
|
|
1591
|
|
|
1592
|
|
|
1593 ;; I/O routines
|
|
|
1594
|
|
|
1595 (defvar teco-output-buffer (get-buffer-create "*Teco Output*")
|
|
|
1596 "The buffer into which Teco output is written.")
|
|
|
1597
|
|
|
1598 (defun teco-out-init ()
|
|
|
1599 ;; Recreate the teco output buffer, if necessary
|
|
|
1600 (setq teco-output-buffer (get-buffer-create "*Teco Output*"))
|
|
|
1601 (save-excursion
|
|
|
1602 (set-buffer teco-output-buffer)
|
|
|
1603 ;; get a fresh line in output buffer
|
|
|
1604 (goto-char (point-max))
|
|
|
1605 (insert ?\n)
|
|
|
1606 ;; remember where to start displaying
|
|
|
1607 (setq teco-output-start (point))
|
|
|
1608 ;; clear minibuffer, in case we have to display in it
|
|
|
1609 (save-window-excursion
|
|
|
1610 (select-window (minibuffer-window))
|
|
|
1611 (erase-buffer))
|
|
|
1612 ;; if output is visible, position it correctly
|
|
|
1613 (let ((w (get-buffer-window teco-output-buffer)))
|
|
|
1614 (if w
|
|
|
1615 (progn
|
|
|
1616 (set-window-start w teco-output-start)
|
|
|
1617 (set-window-point w teco-output-start))))))
|
|
|
1618
|
|
|
1619 (defun teco-output (s)
|
|
|
1620 (let ((w (get-buffer-window teco-output-buffer))
|
|
|
1621 (b (current-buffer))
|
|
|
1622 (sw (selected-window)))
|
|
|
1623 ;; Put the text in the output buffer
|
|
|
1624 (set-buffer teco-output-buffer)
|
|
|
1625 (goto-char (point-max))
|
|
|
1626 (insert s)
|
|
|
1627 (let ((p (point)))
|
|
|
1628 (set-buffer b)
|
|
|
1629 (if w
|
|
|
1630 ;; if output is visible, move the window point to the end
|
|
|
1631 (set-window-point w p)
|
|
|
1632 ;; Otherwise, we have to figure out how to display the text
|
|
|
1633 ;; Has a newline followed by another character been added to the
|
|
|
1634 ;; output buffer? If so, we have to make the output buffer visible.
|
|
|
1635 (if (save-excursion
|
|
|
1636 (set-buffer teco-output-buffer)
|
|
|
1637 (backward-char 1)
|
|
|
1638 (search-backward "\n" teco-output-start t))
|
|
|
1639 ;; a newline has been seen, clear the minibuffer and make the
|
|
|
1640 ;; output buffer visible
|
|
|
1641 (progn
|
|
|
1642 (save-window-excursion
|
|
|
1643 (select-window (minibuffer-window))
|
|
|
1644 (erase-buffer))
|
|
|
1645 (let ((pop-up-windows t))
|
|
|
1646 (pop-to-buffer teco-output-buffer)
|
|
|
1647 (goto-char p)
|
|
|
1648 (set-window-start w teco-output-start)
|
|
|
1649 (set-window-point w p)
|
|
|
1650 (select-window sw)))
|
|
|
1651 ;; a newline has not been seen, add output to minibuffer
|
|
|
1652 (save-window-excursion
|
|
|
1653 (select-window (minibuffer-window))
|
|
|
1654 (goto-char (point-max))
|
|
|
1655 (insert s)))))))
|
|
|
1656
|
|
|
1657 ;; Output a character of tracing information
|
|
|
1658 (defun teco-trace-type (c)
|
|
|
1659 (teco-output (if (= c ?\e)
|
|
|
1660 ?$
|
|
|
1661 c)))
|
|
|
1662
|
|
|
1663 ;; Report an error
|
|
|
1664 (defun teco-error (code)
|
|
|
1665 (let ((text (cdr (assoc code teco-error-texts))))
|
|
|
1666 (teco-output (concat (if (save-excursion (set-buffer teco-output-buffer)
|
|
|
1667 (/= (point) teco-output-start))
|
|
|
1668 "\n"
|
|
|
1669 "")
|
|
|
1670 "? " code " " text))
|
|
|
1671 (beep)
|
|
|
1672 (if debug-on-error (debug nil code text))
|
|
|
1673 (throw 'teco-exit nil)))
|
|
|
1674
|
|
|
1675
|
|
|
1676 ;; Utility routines
|
|
|
1677
|
|
|
1678 ;; copy characters from command string to buffer
|
|
|
1679 (defun teco-moveuntil (string pointer terminate trace)
|
|
|
1680 (let ((count 0))
|
|
|
1681 (condition-case nil
|
|
|
1682 (while (/= (aref string pointer) terminate)
|
|
|
1683 (and teco-trace (teco-trace-type (aref string pointer)))
|
|
|
1684 (insert (aref string pointer))
|
|
|
1685 (setq pointer (1+ pointer))
|
|
|
1686 (setq count (1+ count)))
|
|
|
1687 (error (teco-error (if teco-macro-stack "UTM" "UTC"))))
|
|
|
1688 count))
|
|
|
1689
|
|
|
1690 ;; Convert character to q-register name
|
|
|
1691 ;; If file-or-search is t, allow _, *, %, #
|
|
|
1692 (defun teco-get-qspec (file-or-search char)
|
|
|
1693 ;; lower-case char
|
|
|
1694 (setq char (aref teco-mapch-l char))
|
|
|
1695 ;; test that it's valid
|
|
|
1696 (if (= (logand (aref teco-qspec-valid char) (if file-or-search 2 1)) 0)
|
|
|
1697 (teco-error "IQN"))
|
|
|
1698 char)
|
|
|
1699
|
|
|
1700 ;; Set or get value of a variable
|
|
|
1701 (defun teco-set-var (var)
|
|
|
1702 (if teco-exp-flag1
|
|
|
1703 (progn
|
|
|
1704 (if teco-exp-flag2
|
|
|
1705 ;; if two arguments, they they are <clear bits>, <set bits>
|
|
|
1706 (set var (logior (logand (symbol-value var) (lognot teco-exp-val2))
|
|
|
1707 teco-exp-val1))
|
|
|
1708 ;; if one argument, it is the new value
|
|
|
1709 (set var teco-exp-val1))
|
|
|
1710 ;; consume argument(s)
|
|
|
1711 (setq teco-exp-flag2 nil
|
|
|
1712 teco-exp-flag1 nil))
|
|
|
1713 ;; if no arguments, fetch the value
|
|
|
1714 (setq teco-exp-val1 (symbol-value var)
|
|
|
1715 teco-exp-flag1 t)))
|
|
|
1716
|
|
|
1717 ;; Get numeric argument
|
|
|
1718 (defun teco-get-value (default)
|
|
|
1719 (prog1
|
|
|
1720 (if teco-exp-flag1
|
|
|
1721 teco-exp-val1
|
|
|
1722 (if (eq teco-exp-op 'sub)
|
|
|
1723 (- default)
|
|
|
1724 default))
|
|
|
1725 ;; consume argument
|
|
|
1726 (setq teco-exp-flag1 nil
|
|
|
1727 teco-exp-op 'start)))
|
|
|
1728
|
|
|
1729 ;; Get argument measuring in lines
|
|
|
1730 (defun teco-lines (r)
|
|
|
1731 (- (save-excursion
|
|
|
1732 (if (> r 0)
|
|
|
1733 (if (search-forward "\n" nil t r)
|
|
|
1734 (point)
|
|
|
1735 (point-max))
|
|
|
1736 (if (search-backward "\n" nil t (- 1 r))
|
|
|
1737 (1+ (point))
|
|
|
1738 (point-min))))
|
|
|
1739 (point)))
|
|
|
1740
|
|
|
1741 ;; routine to handle args for K, T, X, etc.
|
|
|
1742 ;; if two args, 'char x' to 'char y'
|
|
|
1743 ;; if just one arg, then n lines (default 1)
|
|
|
1744 (defun teco-line-args (arg)
|
|
|
1745 (if teco-exp-flag2
|
|
|
1746 (cons teco-exp-val1 teco-exp-val2)
|
|
|
1747 (cons (point) (+ (point) (teco-lines (if teco-exp-flag1
|
|
|
1748 teco-exp-val1
|
|
|
1749 1))))))
|
|
|
1750
|
|
|
1751 ;; routine to skip to next ", ', |, <, or >
|
|
|
1752 ;; skips over these chars embedded in text strings
|
|
|
1753 ;; stops in ! if argument is t
|
|
|
1754 ;; returns character found
|
|
|
1755 (defun teco-skipto (&optional arg)
|
|
|
1756 (catch 'teco-skip
|
|
|
1757 (let (;; "at" prefix
|
|
|
1758 (atsw nil)
|
|
|
1759 ;; temp attributes
|
|
|
1760 ta
|
|
|
1761 ;; terminator
|
|
|
1762 term
|
|
|
1763 skipc)
|
|
|
1764 (while t ; forever
|
|
|
1765 (while (progn
|
|
|
1766 (setq skipc (teco-get-command nil)
|
|
|
1767 ta (aref teco-spec-chars skipc))
|
|
|
1768 ;; if char is ^, treat next char as control
|
|
|
1769 (if (eq skipc ?^)
|
|
|
1770 (setq skipc (logand 31 (teco-get-command nil))
|
|
|
1771 ta (aref teco-spec-chars skipc)))
|
|
|
1772 (= (logand ta 51) 0)) ; read until something interesting
|
|
|
1773 ; found
|
|
|
1774 nil)
|
|
|
1775 (if (/= (logand ta 32) 0)
|
|
|
1776 (teco-get-command nil)) ; if command takes a Q spec,
|
|
|
1777 ; skip the spec
|
|
|
1778 (if (/= (logand ta 16) 0) ; sought char found: quit
|
|
|
1779 (progn
|
|
|
1780 (if (= skipc ?\") ; quote must skip next char
|
|
|
1781 (teco-get-command nil))
|
|
|
1782 (throw 'teco-skip skipc)))
|
|
|
1783 (if (/= (logand ta 1) 0) ; other special char
|
|
|
1784 (cond
|
|
|
1785 ((eq skipc ?@) ; use alternative text terminator
|
|
|
1786 (setq atsw t))
|
|
|
1787 ((eq skipc ?\C-^) ; ^^ is value of next char
|
|
|
1788 ; skip that char
|
|
|
1789 (teco-get-command nil))
|
|
|
1790 ((eq skipc ?\C-a) ; type text
|
|
|
1791 (setq term (if atsw (teco-get-command nil) ?\C-a)
|
|
|
1792 atsw nil)
|
|
|
1793 (while (/= (teco-get-command nil) term)
|
|
|
1794 nil)) ; skip text
|
|
|
1795 ((eq skipc ?!) ; tag
|
|
|
1796 (if arg
|
|
|
1797 (throw 'teco-skip skipc))
|
|
|
1798 (while (/= (teco-get-command nil) ?!)
|
|
|
1799 nil)) ; skip until next !
|
|
|
1800 ((or (eq skipc ?e)
|
|
|
1801 (eq skipc ?f)) ; first char of two-letter E or F
|
|
|
1802 ; command
|
|
|
1803 nil))) ; not implemented
|
|
|
1804 (if (/= (logand ta 2) 0) ; command with a text
|
|
|
1805 ; argument
|
|
|
1806 (progn
|
|
|
1807 (setq term (if atsw (teco-get-command nil) ?\e)
|
|
|
1808 atsw nil)
|
|
|
1809 (while (/= (teco-get-command nil) term)
|
|
|
1810 nil) ; skip text
|
|
|
1811 ))))))
|
|
|
1812
|
|
|
1813
|
|
|
1814 (defvar teco-command-keymap
|
|
|
1815 ;; This is what used to be (make-vector 128 'teco-command-self-insert)
|
|
|
1816 ;; Oh well
|
|
|
1817 (let ((map (make-keymap)) (n 127))
|
|
|
1818 (while (>= n 0)
|
|
|
1819 (define-key map (if (< n 32) (list 'control (+ n 32)) n)
|
|
|
1820 'teco-command-self-insert)
|
|
|
1821 (setq n (1- n)))
|
|
|
1822 map)
|
|
|
1823 "Keymap used while reading teco commands.")
|
|
|
1824
|
|
|
1825 (define-key teco-command-keymap "\^g" 'teco-command-ctrl-g)
|
|
|
1826 (define-key teco-command-keymap "\^m" 'teco-command-return)
|
|
|
1827 (define-key teco-command-keymap "\^u" 'teco-command-ctrl-u)
|
|
|
1828 (define-key teco-command-keymap "\e" 'teco-command-escape)
|
|
|
1829 (define-key teco-command-keymap "\^?" 'teco-command-delete)
|
|
|
1830
|
|
|
1831 (defvar teco-command-escapes nil
|
|
|
1832 "Records where ESCs are, since they are represented in the command buffer
|
|
|
1833 by $.")
|
|
|
1834
|
|
|
1835 ;;;###autoload
|
|
|
1836 (defun teco-command ()
|
|
|
1837 "Read and execute a Teco command string."
|
|
|
1838 (interactive)
|
|
|
1839 (let* ((teco-command-escapes nil)
|
|
|
1840 (command (catch 'teco-command-quit
|
|
|
1841 (read-from-minibuffer teco-prompt nil
|
|
|
1842 teco-command-keymap))))
|
|
|
1843 (if command
|
|
|
1844 (progn
|
|
|
1845 (while teco-command-escapes
|
|
|
1846 (aset command (car teco-command-escapes) ?\e)
|
|
|
1847 (setq teco-command-escapes (cdr teco-command-escapes)))
|
|
|
1848 (setq teco-output-buffer (get-buffer-create "*Teco Output*"))
|
|
|
1849 (save-excursion
|
|
|
1850 (set-buffer teco-output-buffer)
|
|
|
1851 (goto-char (point-max))
|
|
|
1852 (insert teco-prompt command))
|
|
|
1853 (teco-execute-command command)))))
|
|
|
1854
|
|
|
1855 (defun teco-read-command ()
|
|
|
1856 "Read a teco command string from the user."
|
|
|
1857 (let ((command (catch 'teco-command-quit
|
|
|
1858 (read-from-minibuffer teco-prompt nil
|
|
|
1859 teco-command-keymap)))
|
|
|
1860 teco-command-escapes)
|
|
|
1861 (if command
|
|
|
1862 (while teco-command-escapes
|
|
|
1863 (aset command (car teco-command-escapes ?\e))
|
|
|
1864 (setq teco-command-escapes (cdr teco-command-escapes))))
|
|
|
1865 command))
|
|
|
1866
|
|
|
1867 (defun teco-command-self-insert ()
|
|
|
1868 (interactive)
|
|
|
1869 (insert last-command-char)
|
|
|
1870 (if (not (pos-visible-in-window-p))
|
|
|
1871 (enlarge-window 1)))
|
|
|
1872
|
|
|
1873 (defun teco-command-ctrl-g ()
|
|
|
1874 (interactive)
|
|
|
1875 (beep)
|
|
|
1876 (throw 'teco-command-quit nil))
|
|
|
1877
|
|
|
1878 (defun teco-command-return ()
|
|
|
1879 (interactive)
|
|
|
1880 (setq last-command-char ?\n)
|
|
|
1881 (teco-command-self-insert))
|
|
|
1882
|
|
|
1883 (defun teco-command-escape ()
|
|
|
1884 (interactive)
|
|
|
1885 ;; Two ESCs in a row terminate the command string
|
|
|
1886 (if (eq last-command 'teco-command-escape)
|
|
|
1887 (throw 'teco-command-quit (buffer-string)))
|
|
|
1888 (setq teco-command-escapes (cons (1- (point)) teco-command-escapes))
|
|
|
1889 (setq last-command-char ?$)
|
|
|
1890 (teco-command-self-insert))
|
|
|
1891
|
|
|
1892 (defun teco-command-ctrl-u ()
|
|
|
1893 (interactive)
|
|
|
1894 ;; delete the characters
|
|
|
1895 (kill-line 0)
|
|
|
1896 ;; forget that they were ESCs
|
|
|
1897 (while (and teco-command-escapes (<= (point) (car teco-command-escapes)))
|
|
|
1898 (setq teco-command-escapes (cdr teco-command-escapes)))
|
|
|
1899 ;; decide whether to shrink the window
|
|
|
1900 (while (let ((a (insert ?\n))
|
|
|
1901 (b (pos-visible-in-window-p))
|
|
|
1902 (c (backward-delete-char 1)))
|
|
|
1903 b)
|
|
|
1904 (shrink-window 1)))
|
|
|
1905
|
|
|
1906 (defun teco-command-delete ()
|
|
|
1907 (interactive)
|
|
|
1908 ;; delete the character
|
|
|
1909 (backward-delete-char 1)
|
|
|
1910 ;; forget that it was an ESC
|
|
|
1911 (if (and teco-command-escapes (= (point) (car teco-command-escapes)))
|
|
|
1912 (setq teco-command-escapes (cdr teco-command-escapes)))
|
|
|
1913 ;; decide whether to shrink the window
|
|
|
1914 (insert ?\n)
|
|
|
1915 (if (prog1 (pos-visible-in-window-p)
|
|
|
1916 (backward-delete-char 1))
|
|
|
1917 (shrink-window 1)))
|
|
|
1918
|
|
|
1919 (provide 'teco)
|
|
|
1920
|
|
|
1921 ;;; teco.el ends here
|
