cgit.sxemacs.org Git - packages/blob - xemacs-packages/prog-modes/teco.el

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