Mercurial > hg > xemacs-beta
comparison lisp/emulators/teco.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:45:50 +0200 |
| parents | |
| children | b82b59fe008d |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:376386a54a3c |
|---|---|
| 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 |