Mercurial > hg > xemacs-beta
diff 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 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emulators/teco.el Mon Aug 13 08:45:50 2007 +0200 @@ -0,0 +1,1921 @@ +;;; teco.el --- Teco interpreter for Gnu Emacs, version 1. + +(require 'backquote) +;; This code has been tested some, but no doubt contains a zillion bugs. +;; You have been warned. + +;; Written by Dale R. Worley based on a C implementation by Matt Fichtenbaum. +;; Please send comments, bug fixes, enhancements, etc. to drw@math.mit.edu. + +;; Emacs Lisp version copyright (C) 1991 by Dale R. Worley. +;; Do what you will with it. + +;; Since much of this code is translated from the C version by +;; Matt Fichtenbaum, I include his copyright notice: +;; TECO for Ultrix. Copyright 1986 Matt Fichtenbaum. +;; This program and its components belong to GenRad Inc, Concord MA 01742. +;; They may be copied if this copyright notice is included. + +;; To invoke directly, do: +;; (global-set-key ?\C-z 'teco-command) +;; (autoload teco-command "teco" +;; "Read and execute a Teco command string." +;; t nil) + +;; Differences from other Tecos: +;; Character positions in the buffer are numbered in the Emacs way: The first +;; character is numbered 1 (or (point-min) if narrowing is in effect). The +;; B command returns that number. +;; Ends of lines are represented by a single character (newline), so C and R +;; skip over them, rather than 2C and 2R. +;; All file I/O is left to the underlying Emacs. Thus, almost all Ex commands +;; are omitted. + +;; Command set: +;; NUL Not a command. +;; ^A Output message to terminal (argument ends with ^A) +;; ^C Exit macro +;; ^C^C Stop execution +;; ^D Set radix to decimal +;; ^EA (match char) Match alphabetics +;; ^EC (match char) Match symbol constituents +;; ^ED (match char) Match numerics +;; ^EGq (match char) Match any char in q-reg +;; ^EL (match char) Match line terminators +;; ^EQq (string char) Use contents of q-reg +;; ^ER (match char) Match alphanumerics +;; ^ES (match char) Match non-null space/tab +;; ^EV (match char) Match lower case alphabetic +;; ^EW (match char) Match upper case alphabetic +;; ^EX (match char) Match any char +;; ^G^G (type-in) Kill command string +;; ^G<sp> (type-in) Retype current command line +;; ^G* (type-in) Retype current command input +;; TAB Insert tab and text +;; LF Line terminator; Ignored in commands +;; VT Ignored in commands +;; FF Ignored in commands +;; CR Ignored in commands +;; ^Nx (match char) Match all but x +;; ^O Set radix to octal +;; ^P Find matching parenthesis +;; ^Q Convert line argument into character argument +;; ^Qx (string char) Use x literally +;; n^R Set radix to n +;; :^R Enter recursive edit +;; ^S -(length of last referenced string) +;; ^S (match char) match separator char +;; ^T Ascii value of next character typed +;; n^T Output Ascii character with value n +;; ^U (type-in) Kill command line +;; ^Uq Put text argument into q-reg +;; n^Uq Put Ascii character 'n' into q-reg +;; :^Uq Append text argument to q-reg +;; n:^Uq Append character 'n' to q-reg +;; ^X Set/get search mode flag +;; ^X (match char) Match any character +;; ^Y Equivalent to '.+^S,.' +;; ^Z Not a Teco command +;; ESC String terminator; absorbs arguments +;; ESC ESC (type-in) End command +;; ^\ Not a Teco command +;; ^] Not a Teco command +;; ^^x Ascii value of the character x +;; ^_ One's complement (logical NOT) +;; ! Define label (argument ends with !) +;; " Start conditional +;; n"< Test for less than zero +;; n"> Test for greater than zero +;; n"= Test for equal to zero +;; n"A Test for alphabetic +;; n"C Test for symbol constituent +;; n"D Test for numeric +;; n"E Test for equal to zero +;; n"F Test for false +;; n"G Test for greater than zero +;; n"L Test for less than zero +;; n"N Test for not equal to zero +;; n"R Test for alphanumeric +;; n"S Test for successful +;; n"T Test for true +;; n"U Test for unsuccessful +;; n"V Test for lower case +;; n"W Test for upper case +;; # Logical OR +;; $ Not a Teco command +;; n%q Add n to q-reg and return result +;; & Logical AND +;; ' End conditional +;; ( Expression grouping +;; ) Expression grouping +;; * Multiplication +;; + Addition +;; , Argument separator +;; - Subtraction or negation +;; . Current pointer position +;; / Division +;; 0-9 Digit +;; n< Iterate n times +;; = Type in decimal +;; := Type in decimal, no newline +;; = Type in octal +;; := Type in octal, no newline +;; = Type in hexadecimal +;; := Type in hexadecimal, no newline +;; :: Make next search a compare +;; > End iteration +;; n:A Get Ascii code of character at relative position n +;; B Character position of beginning of buffer +;; nC Advance n characters +;; nD Delete n characters +;; n,mD Delete characters between n and m +;; Gq Get string from q-reg into buffer +;; :Gq Type out q-reg +;; H Equivalent to 'B,Z' +;; I Insert text argument +;; nJ Move pointer to character n +;; nK Kill n lines +;; n,mK Kill characters between n and m +;; nL Advance n lines +;; Mq Execute string in q-reg +;; O Goto label +;; nO Go to n-th label in list (0-origin) +;; Qq Number in q-reg +;; nQq Ascii value of n-th character in q-reg +;; :Qq Size of text in q-reg +;; nR Back up n characters +;; nS Search +;; nT Type n lines +;; n,mT Type chars from n to m +;; nUq Put number n into q-reg +;; nV Type n lines around pointer +;; nXq Put n lines into q-reg +;; n,mXq Put characters from n to m into q-reg +;; n:Xq Append n lines to q-reg q +;; n,m:Xq Append characters from n to m into q-reg +;; Z Pointer position at end of buffer +;; [q Put q-reg on stack +;; \ Value of digit string in buffer +;; n\ Convert n to digits and insert in buffer +;; ]q Pop q-reg from stack +;; :]q Test whether stack is empty and return value +;; ` Not a Teco command +;; a-z Treated the same as A-Z +;; { Not a Teco command +;; | Conditional 'else' +;; } Not a Teco comand +;; ~ Not a Teco command +;; DEL Delete last character typed in + + +;; set a range of elements of an array to a value +(defun teco-set-elements (array start end value) + (let ((i start)) + (while (<= i end) + (aset array i value) + (setq i (1+ i))))) + +;; set a range of elements of an array to their indexes plus an offset +(defun teco-set-elements-index (array start end offset) + (let ((i start)) + (while (<= i end) + (aset array i (+ i offset)) + (setq i (1+ i))))) + +(defvar teco-command-string "" + "The current command string being executed.") + +(defvar teco-command-pointer nil + "Pointer into teco-command-string showing next character to be executed.") + +(defvar teco-ctrl-r 10 + "Current number radix.") + +(defvar teco-digit-switch nil + "Set if we have just executed a digit.") + +(defvar teco-exp-exp nil + "Expression value preceeding operator.") + +(defvar teco-exp-val1 nil + "Current argument value.") + +(defvar teco-exp-val2 nil + "Argument before comma.") + +(defvar teco-exp-flag1 nil + "t if argument is present.") + +(defvar teco-exp-flag2 nil + "t if argument before comma is present.") + +(defvar teco-exp-op nil + "Pending arithmetic operation on argument.") + +(defvar teco-exp-stack nil + "Stack for parenthesized expressions.") + +(defvar teco-macro-stack nil + "Stack for macro invocations.") + +(defvar teco-mapch-l nil + "Translation table to lower-case letters.") + + (setq teco-mapch-l (make-vector 256 0)) + (teco-set-elements-index teco-mapch-l 0 255 0) + (teco-set-elements-index teco-mapch-l ?A ?Z (- ?a ?A)) + +(defvar teco-trace nil + "t if tracing is on.") + +(defvar teco-at-flag nil + "t if an @ flag is pending.") + +(defvar teco-colon-flag nil + "1 if a : flag is pending, 2 if a :: flag is pending.") + +(defvar teco-qspec-valid nil + "Flags describing whether a character is a vaid q-register name. +3 means yes, 2 means yes but only for file and search operations.") + + (setq teco-qspec-valid (make-vector 256 0)) + (teco-set-elements teco-qspec-valid ?a ?z 3) + (teco-set-elements teco-qspec-valid ?0 ?9 3) + (aset teco-qspec-valid ?_ 2) + (aset teco-qspec-valid ?* 2) + (aset teco-qspec-valid ?% 2) + (aset teco-qspec-valid ?# 2) + +(defvar teco-exec-flags 0 + "Flags for iteration in process, ei macro, etc.") + +(defvar teco-iteration-stack nil + "Iteration list.") + +(defvar teco-cond-stack nil + "Conditional stack.") + +(defvar teco-qreg-text (make-vector 256 "") + "The text contents of the q-registers.") + +(defvar teco-qreg-number (make-vector 256 0) + "The number contents of the q-registers.") + +(defvar teco-qreg-stack nil + "The stack of saved q-registers.") + +(defconst teco-prompt "*" + "*Prompt to be used when inputting Teco command.") + +(defconst teco-exec-1 (make-vector 256 nil) + "Names of routines handling type 1 characters (characters that are +part of expression processing).") + +(defconst teco-exec-2 (make-vector 256 nil) + "Names of routines handling type 2 characters (characters that are +not part of expression processing).") + +(defvar teco-last-search-string "" + "Last string searched for.") + +(defvar teco-last-search-regexp "" + "Regexp version of teco-last-search-string.") + +(defmacro teco-define-type-1 (char &rest body) + "Define the code to process a type 1 character. +Transforms + (teco-define-type-1 ?x + code ...) +into + (defun teco-type-1-x () + code ...) +and does + (aset teco-exec-1 ?x 'teco-type-1-x)" + (let ((s (intern (concat "teco-type-1-" (char-to-string char))))) + (` (progn + (defun (, s) () + (,@ body)) + (aset teco-exec-1 (, char) '(, s)))))) + +(defmacro teco-define-type-2 (char &rest body) + "Define the code to process a type 2 character. +Transforms + (teco-define-type-2 ?x + code ...) +into + (defun teco-type-2-x () + code ...) +and does + (aset teco-exec-2 ?x 'teco-type-2-x)" + (let ((s (intern (concat "teco-type-2-" (char-to-string char))))) + (` (progn + (defun (, s) () + (,@ body)) + (aset teco-exec-2 (, char) '(, s)))))) + +(defconst teco-char-types (make-vector 256 0) + "Define the characteristics of characters, as tested by \": + 1 alphabetic + 2 alphabetic, $, or . + 4 digit + 8 alphabetic or digit + 16 lower-case alphabetic + 32 upper-case alphabetic") + + (teco-set-elements teco-char-types ?0 ?9 (+ 4 8)) + (teco-set-elements teco-char-types ?A ?Z (+ 1 2 8 32)) + (teco-set-elements teco-char-types ?a ?z (+ 1 2 8 16)) + (aset teco-char-types ?$ 2) + (aset teco-char-types ?. 2) + +(defconst teco-error-texts '(("BNI" . "> not in iteration") + ("CPQ" . "Can't pop Q register") + ("COF" . "Can't open output file ") + ("FNF" . "File not found ") + ("IEC" . "Invalid E character") + ("IFC" . "Invalid F character") + ("IIA" . "Invalid insert arg") + ("ILL" . "Invalid command") + ("ILN" . "Invalid number") + ("IPA" . "Invalid P arg") + ("IQC" . "Invalid \" character") + ("IQN" . "Invalid Q-reg name") + ("IRA" . "Invalid radix arg") + ("ISA" . "Invalid search arg") + ("ISS" . "Invalid search string") + ("IUC" . "Invalid ^ character") + ("LNF" . "Label not found") + ("MEM" . "Insufficient memory available") + ("MRP" . "Missing )") + ("NAB" . "No arg before ^_") + ("NAC" . "No arg before ,") + ("NAE" . "No arg before =") + ("NAP" . "No arg before )") + ("NAQ" . "No arg before \"") + ("NAS" . "No arg before ;") + ("NAU" . "No arg before U") + ("NFI" . "No file for input") + ("NFO" . "No file for output") + ("NYA" . "Numeric arg with Y") + ("OFO" . "Output file already open") + ("PDO" . "Pushdown list overflow") + ("POP" . "Pointer off page") + ("SNI" . "; not in iteration") + ("SRH" . "Search failure ") + ("STL" . "String too long") + ("UTC" . "Unterminated command") + ("UTM" . "Unterminated macro") + ("XAB" . "Execution interrupted") + ("YCA" . "Y command suppressed") + ("IWA" . "Invalid W arg") + ("NFR" . "Numeric arg with FR") + ("INT" . "Internal error") + ("EFI" . "EOF read from std input") + ("IAA" . "Invalid A arg") + )) + +(defconst teco-spec-chars + [ + 0 1 0 0 ; ^@ ^A ^B ^C + 0 64 0 0 ; ^D ^E ^F ^G + 0 2 128 128 ; ^H ^I ^J ^K + 128 0 64 0 ; ^L ^M ^N ^O + 0 64 64 64 ; ^P ^Q ^R ^S + 0 34 0 0 ; ^T ^U ^V ^W + 64 0 0 0 ; ^X ^Y ^Z ^\[ + 0 0 1 0 ; ^\ ^\] ^^ ^_ + 0 1 16 0 ; ! \" # + 0 0 0 16 ; $ % & ' + 0 0 0 0 ; \( \) * + + 0 0 0 0 ; , - . / + 0 0 0 0 ; 0 1 2 3 + 0 0 0 0 ; 4 5 6 7 + 0 0 0 0 ; 8 9 : ; + 16 0 16 0 ; < = > ? + 1 0 12 0 ; @ A B C + 0 1 1 32 ; D E F G + 0 6 0 0 ; H I J K + 0 32 10 2 ; L M N O + 0 32 4 10 ; P Q R S + 0 32 0 4 ; T U V W + 32 0 0 32 ; X Y Z \[ + 0 32 1 6 ; \ \] ^ _ + 0 0 12 0 ; ` a b c + 0 1 1 32 ; d e f g + 0 6 0 0 ; h i j k + 0 32 10 2 ; l m n o + 0 32 4 10 ; p q r s + 0 32 0 4 ; t u v w + 32 0 0 0 ; x y z { + 16 0 0 0 ; | } ~ DEL + ] + "The special properties of characters: + 1 skipto() special character + 2 command with std text argument + 4 E<char> takes a text argument + 8 F<char> takes a text argument + 16 char causes skipto() to exit + 32 command with q-register argument + 64 special char in search string + 128 character is a line separator") + + +(defun teco-execute-command (string) + "Execute teco command string." + ;; Initialize everything + (let ((teco-command-string string) + (teco-command-pointer 0) + (teco-digit-switch nil) + (teco-exp-exp nil) + (teco-exp-val1 nil) + (teco-exp-val2 nil) + (teco-exp-flag1 nil) + (teco-exp-flag2 nil) + (teco-exp-op 'start) + (teco-trace nil) + (teco-at-flag nil) + (teco-colon-flag nil) + (teco-exec-flags 0) + (teco-iteration-stack nil) + (teco-cond-stack nil) + (teco-exp-stack nil) + (teco-macro-stack nil) + (teco-qreg-stack nil)) + ;; initialize output + (teco-out-init) + ;; execute commands + (catch 'teco-exit + (while t + ;; get next command character + (let ((cmdc (teco-get-command0 teco-trace))) + ;; if it's ^, interpret the next character as a control character + (if (eq cmdc ?^) + (setq cmdc (logand (teco-get-command teco-trace) 31))) + (if (and (<= ?0 cmdc) (<= cmdc ?9)) + ;; process a number + (progn + (setq cmdc (- cmdc ?0)) + ;; check for invalid digit + (if (>= cmdc teco-ctrl-r) + (teco-error "ILN")) + (if teco-digit-switch + ;; later digits + (setq teco-exp-val1 (+ (* teco-exp-val1 teco-ctrl-r) cmdc)) + ;; first digit + (setq teco-exp-val1 cmdc) + (setq teco-digit-switch t)) + ;; indicate a value was read in + (setq teco-exp-flag1 t)) + ;; not a digit + (setq teco-digit-switch nil) + ;; cannonicalize the case + (setq cmdc (aref teco-mapch-l cmdc)) + ;; dispatch on the character, if it is a type 1 character + (let ((r (aref teco-exec-1 cmdc))) + (if r + (funcall r) + ;; if a value has been entered, process any pending operation + (if teco-exp-flag1 + (cond ((eq teco-exp-op 'start) + nil) + ((eq teco-exp-op 'add) + (setq teco-exp-val1 (+ teco-exp-exp teco-exp-val1)) + (setq teco-exp-op 'start)) + ((eq teco-exp-op 'sub) + (setq teco-exp-val1 (- teco-exp-exp teco-exp-val1)) + (setq teco-exp-op 'start)) + ((eq teco-exp-op 'mult) + (setq teco-exp-val1 (* teco-exp-exp teco-exp-val1)) + (setq teco-exp-op 'start)) + ((eq teco-exp-op 'div) + (setq teco-exp-val1 + (if (/= teco-exp-val1 0) + (/ teco-exp-exp teco-exp-val1) + 0)) + (setq teco-exp-op 'start)) + ((eq teco-exp-op 'and) + (setq teco-exp-val1 + (logand teco-exp-exp teco-exp-val1)) + (setq teco-exp-op 'start)) + ((eq teco-exp-op 'or) + (setq teco-exp-val1 + (logior teco-exp-exp teco-exp-val1)) + (setq teco-exp-op 'start)))) + ;; dispatch on a type 2 character + (let ((r (aref teco-exec-2 cmdc))) + (if r + (funcall r) + (teco-error "ILL"))))))))))) + +;; Type 1 commands + +(teco-define-type-1 + ?\m ; CR + nil) + +(teco-define-type-1 + ?\n ; LF + nil) + +(teco-define-type-1 + ?\^k ; VT + nil) + +(teco-define-type-1 + ?\^l ; FF + nil) + +(teco-define-type-1 + 32 ; SPC + nil) + +(teco-define-type-1 + ?\e ; ESC + (if (teco-peek-command ?\e) + ;; ESC ESC terminates macro or command + (teco-pop-macro-stack) + ;; otherwise, consume argument + (setq teco-exp-flag1 nil) + (setq teco-exp-op 'start))) + +(teco-define-type-1 + ?! ; ! + (while (/= (teco-get-command teco-trace) ?!) + nil)) + +(teco-define-type-1 + ?@ ; @ + ;; set at-flag + (setq teco-at-flag t)) + +(teco-define-type-1 + ?: ; : + ;; is it '::'? + (if (teco-peek-command ?:) + (progn + ;; skip second colon + (teco-get-command teco-trace) + ;; set flag to show two colons + (setq teco-colon-flag 2)) + ;; set flag to show one colon + (setq teco-colon-flag 1))) + +(teco-define-type-1 + ?? ; ? + ;; toggle trace + (setq teco-trace (not teco-trace))) + +(teco-define-type-1 + ?. ; . + ;; value is point + (setq teco-exp-val1 (point) + teco-exp-flag1 t)) + +(teco-define-type-1 + ?z ; z + ;; value is point-max + (setq teco-exp-val1 (point-max) + teco-exp-flag1 t)) + +(teco-define-type-1 + ?b ; b + ;; value is point-min + (setq teco-exp-val1 (point-min) + teco-exp-flag1 t)) + +(teco-define-type-1 + ?h ; h + ;; value is b,z + (setq teco-exp-val1 (point-max) + teco-exp-val2 (point-min) + teco-exp-flag1 t + teco-exp-flag2 t + teco-exp-op 'start)) + +(teco-define-type-1 + ?\^s ; ^s + ;; value is - length of last insert, etc. + (setq teco-exp-val1 teco-ctrl-s + teco-exp-flag1 t)) + +(teco-define-type-1 + ?\^y ; ^y + ;; value is .+^S,. + (setq teco-exp-val1 (+ (point) teco-ctrl-s) + teco-exp-val2 (point) + teco-exp-flag1 t + teco-exp-flag2 t + teco-exp-op 'start)) + +(teco-define-type-1 + ?\( ; \( + ;; push expression stack + (teco-push-exp-stack) + (setq teco-exp-flag1 nil + teco-exp-flag2 nil + teco-exp-op 'start)) + +(teco-define-type-1 + ?\^p ; ^p + (teco-do-ctrl-p)) + +(teco-define-type-1 + ?\C-^ ; ^^ + ;; get next command character + (setq teco-exp-val1 (teco-get-command teco-trace) + teco-exp-flag1 t)) + + +;; Type 2 commands +(teco-define-type-2 + ?+ ; + + (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0) + teco-exp-flag1 nil + teco-exp-op 'add)) + +(teco-define-type-2 + ?- ; - + (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0) + teco-exp-flag1 nil + teco-exp-op 'sub)) + +(teco-define-type-2 + ?* ; * + (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0) + teco-exp-flag1 nil + teco-exp-op 'mult)) + +(teco-define-type-2 + ?/ ; / + (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0) + teco-exp-flag1 nil + teco-exp-op 'div)) + +(teco-define-type-2 + ?& ; & + (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0) + teco-exp-flag1 nil + teco-exp-op 'and)) + +(teco-define-type-2 + ?# ; # + (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0) + teco-exp-flag1 nil + teco-exp-op 'or)) + +(teco-define-type-2 + ?\) ; \) + (if (or (not teco-exp-flag1) (not teco-exp-stack)) + (teco-error "NAP")) + (let ((v teco-exp-val1)) + (teco-pop-exp-stack) + (setq teco-exp-val1 v + teco-exp-flag1 t))) + +(teco-define-type-2 + ?, ; , + (if (not teco-exp-flag1) + (teco-error "NAC")) + (setq teco-exp-val2 teco-exp-val1 + teco-exp-flag2 t + teco-exp-flag1 nil)) + +(teco-define-type-2 + ?\^_ ; ^_ + (if (not teco-exp-flag1) + (teco-error "NAB") + (setq teco-exp-val1 (lognot teco-exp-val1)))) + +(teco-define-type-2 + ?\^d ; ^d + (setq teco-ctrl-r 10 + teco-exp-flag1 nil + teco-exp-op 'start)) + +(teco-define-type-2 + ?\^o ; ^o + (setq teco-ctrl-r 8 + teco-exp-flag1 nil + teco-exp-op 'start)) + +(teco-define-type-2 + ?\^r ; ^r + (if teco-colon-flag + (progn + (recursive-edit) + (setq teco-colon-flag nil)) + (if teco-exp-flag1 + ;; set radix + (progn + (if (and (/= teco-exp-val1 8) + (/= teco-exp-val1 10) + (/= teco-exp-val1 16)) + (teco-error "IRA")) + (setq teco-ctrl-r teco-exp-val1 + teco-exp-flag1 nil + teco-exp-op 'start)) + ;; get radix + (setq teco-exp-val1 teco-ctrl-r + teco-exp-flag1 t)))) + +(teco-define-type-2 + ?\^c ; ^c + (if (teco-peek-command ?\^c) + ;; ^C^C stops execution + (throw 'teco-exit nil) + (if teco-macro-stack + ;; ^C inside macro exits macro + (teco-pop-macro-stack) + ;; ^C in command stops execution + (throw 'teco-exit nil)))) + +(teco-define-type-2 + ?\^x ; ^x + ;; set/get search mode flag + (teco-set-var 'teco-ctrl-x)) + +(teco-define-type-2 + ?m ; m + (let ((macro-name (teco-get-qspec nil + (teco-get-command teco-trace)))) + (teco-push-macro-stack) + (setq teco-command-string (aref teco-qreg-text macro-name) + teco-command-pointer 0))) + +(teco-define-type-2 + ?< ; < + ;; begin iteration + (if (and teco-exp-flag1 (<= teco-exp-val1 0)) + ;; if this is not to be executed, just skip the + ;; intervening stuff + (teco-find-enditer) + ;; push iteration stack + (teco-push-iter-stack teco-command-pointer + teco-exp-flag1 teco-exp-val1) + ;; consume the argument + (setq teco-exp-flag1 nil))) + +(teco-define-type-2 + ?> ; > + ;; end iteration + (if (not teco-iteration-stack) + (teco-error "BNI")) + ;; decrement count and pop conditionally + (teco-pop-iter-stack nil) + ;; consume arguments + (setq teco-exp-flag1 nil + teco-exp-flag2 nil + teco-exp-op 'start)) + +(teco-define-type-2 + 59 ; ; + ;; semicolon iteration exit + (if (not teco-iteration-stack) + (teco-error "SNI")) + ;; if exit + (if (if (>= (if teco-exp-flag1 + teco-exp-val1 + teco-search-result) 0) + (not teco-colon-flag) + teco-colon-flag) + (progn + (teco-find-enditer) + (teco-pop-iter-stack t))) + ;; consume argument and colon + (setq teco-exp-flag1 nil + teco-colon-flag nil + teco-exp-op 'start)) + +(teco-define-type-2 + ?\" ; \" + ;; must be an argument + (if (not teco-exp-flag1) + (teco-error "NAQ")) + ;; consume argument + (setq teco-exp-flag1 nil + teco-exp-op 'start) + (let* (;; get the test specification + (c (aref teco-mapch-l (teco-get-command teco-trace))) + ;; determine whether the test is true + (test (cond ((eq c ?a) + (/= (logand (aref teco-char-types teco-exp-val1) + 1) 0)) + ((eq c ?c) + (/= (logand (aref teco-char-types teco-exp-val1) + 2) 0)) + ((eq c ?d) + (/= (logand (aref teco-char-types teco-exp-val1) + 4) 0)) + ((or (eq c ?e) (eq c ?f) (eq c ?u) (eq c ?=)) + (= teco-exp-val1 0)) + ((or (eq c ?g) (eq c ?>)) + (> teco-exp-val1 0)) + ((or (eq c ?l) (eq c ?s) (eq c ?t) (eq c ?<)) + (< teco-exp-val1 0)) + ((eq c ?n) + (/= teco-exp-val1 0)) + ((eq c ?r) + (/= (logand (aref teco-char-types teco-exp-val1) + 8) 0)) + ((eq c ?v) + (/= (logand (aref teco-char-types teco-exp-val1) + 16) 0)) + ((eq c ?w) + (/= (logand (aref teco-char-types teco-exp-val1) + 32) 0)) + (t + (teco-error "IQC"))))) + (if (not test) + ;; if the conditional isn't satisfied, read + ;; to matching | or ' + (let ((ll 1) + c) + (while (> ll 0) + (while (progn (setq c (teco-skipto)) + (and (/= c ?\") + (/= c ?|) + (/= c ?\'))) + (if (= c ?\") + (setq ll (1+ ll)) + (if (= c ?\') + (setq ll (1- ll)) + (if (= ll 1) + (break)))))))))) + +(teco-define-type-2 + ?' ; ' + ;; ignore it if executing + t) + +(teco-define-type-2 + ?| ; | + (let ((ll 1) + c) + (while (> ll 0) + (while (progn (setq c (teco-skipto)) + (and (/= c ?\") + (/= c ?\'))) + nil) + (if (= c ?\") + (setq ll (1+ ll)) + (setq ll (1- ll)))))) + +(teco-define-type-2 + ?u ; u + (if (not teco-exp-flag1) + (teco-error "NAU")) + (aset teco-qreg-number + (teco-get-qspec 0 (teco-get-command teco-trace)) + teco-exp-val1) + (setq teco-exp-flag1 teco-exp-flag2 ; command's value is second arg + teco-exp-val1 teco-exp-val2 + teco-exp-flag2 nil + teco-exp-op 'start)) + +(teco-define-type-2 + ?q ; q + ;; Qn is numeric val, :Qn is # of chars, mQn is mth char + (let ((mm (teco-get-qspec (or teco-colon-flag teco-exp-flag1) + (teco-get-command teco-trace)))) + (if (not teco-exp-flag1) + (setq teco-exp-val1 (if teco-colon-flag + ;; :Qn + (length (aref teco-qreg-text mm)) + ;; Qn + (aref teco-qreg-number mm)) + teco-exp-flag1 t) + ;; mQn + (let ((v (aref teco-qreg-text mm))) + (setq teco-exp-val1 (condition-case nil + (aref v teco-exp-val1) + (error -1)) + teco-exp-op 'start))) + (setq teco-colon-flag nil))) + +(teco-define-type-2 + ?% ; % + (let* ((mm (teco-get-qspec nil (teco-get-command teco-trace))) + (v (+ (aref teco-qreg-number mm) (teco-get-value 1)))) + (aset teco-qreg-number mm v) + (setq teco-exp-val1 v + teco-exp-flag1 t))) + +(teco-define-type-2 + ?c ; c + (let ((p (+ (point) (teco-get-value 1)))) + (if (or (< p (point-min)) (> p (point-max))) + (teco-error "POP") + (goto-char p) + (setq teco-exp-flag2 nil)))) + +(teco-define-type-2 + ?r ; r + (let ((p (- (point) (teco-get-value 1)))) + (if (or (< p (point-min)) (> p (point-max))) + (teco-error "POP") + (goto-char p) + (setq teco-exp-flag2 nil)))) + +(teco-define-type-2 + ?j ; j + (let ((p (teco-get-value (point-min)))) + (if (or (< p (point-min)) (> p (point-max))) + (teco-error "POP") + (goto-char p) + (setq teco-exp-flag2 nil)))) + +(teco-define-type-2 + ?l ; l + ;; move forward by lines + (forward-char (teco-lines (teco-get-value 1)))) + +(teco-define-type-2 + ?\C-q ; ^q + ;; number of characters until the nth line feed + (setq teco-exp-val1 (teco-lines (teco-get-value 1)) + teco-exp-flag1 t)) + +(teco-define-type-2 + ?= ; = + ;; print numeric value + (if (not teco-exp-flag1) + (teco-error "NAE")) + (teco-output (format + (if (teco-peek-command ?=) + ;; at least one more = + (progn + ;; read past it + (teco-get-command teco-trace) + (if (teco-peek-command ?=) + ;; another? + (progn + ;; read it too + (teco-get-command teco-trace) + ;; print in hex + "%x") + ;; print in octal + "%o")) + ;; print in decimal + "%d") + teco-exp-val1)) + ;; add newline if no colon + (if (not teco-colon-flag) + (teco-output ?\n)) + ;; absorb argument, etc. + (setq teco-exp-flag1 nil + teco-exp-flag2 nil + teco-colon-flag nil + teco-exp-op 'start)) + +(teco-define-type-2 + ?\t ; TAB + (if exp-flag1 + (teco-error "IIA")) + (let ((text (teco-get-text-arg))) + (insert ?\t text) + (setq teco-ctrl-s (1+ (length text)))) + ;; clear arguments + (setq teco-colon-flag nil + teco-exp-flag1 nil + teco-exp-flag2 nil)) + +(teco-define-type-2 + ?i ; i + (let ((text (teco-get-text-arg))) + (if teco-exp-flag1 + ;; if a nI$ command + (progn + ;; text argument must be null + (or (string-equal text "") (teco-error "IIA")) + ;; insert the character + (insert teco-exp-val1) + (setq teco-ctrl-s 1) + ;; consume argument + (setq teco-exp-op 'start)) + ;; otherwise, insert the text + (insert text) + (setq teco-ctrl-s (length text))) + ;; clear arguments + (setq teco-colon-flag nil + teco-exp-flag1 nil + teco-exp-flag2 nil))) + +(teco-define-type-2 + ?t ; t + (let ((args (teco-line-args nil))) + (teco-output (buffer-substring (car args) (cdr args))))) + +(teco-define-type-2 + ?v ; v + (let ((ll (teco-get-value 1))) + (teco-output (buffer-substring (+ (point) (teco-lines (- 1 ll))) + (+ (point) (teco-lines ll)))))) + +(teco-define-type-2 + ?\C-a ; ^a + (teco-output (teco-get-text-arg nil ?\C-a)) + (setq teco-at-flag nil + teco-colon-flag nil + teco-exp-flag1 nil + teco-exp-flag2 nil + teco-exp-op 'start)) + +(teco-define-type-2 + ?d ; d + (if (not teco-exp-flag2) + ;; if only one argument + (delete-char (teco-get-value 1)) + ;; if two arguments, treat as n,mK + (let ((ll (teco-line-args 1))) + (delete-region (car ll) (cdr ll))))) + +(teco-define-type-2 + ?k ; k + (let ((ll (teco-line-args 1))) + (delete-region (car ll) (cdr ll)))) + +(teco-define-type-2 + ?\C-u ; ^u + (let* ((mm (teco-get-qspec nil (teco-get-command teco-trace))) + (text-arg (teco-get-text-arg)) + (text (if (not teco-exp-flag1) + text-arg + (if (string-equal text-arg "") + (char-to-string teco-exp-val1) + (teco-error "IIA"))))) + ;; if :, append to the register + (aset teco-qreg-text mm (if teco-colon-flag + (concat (aref teco-qreg-text mm) text) + text)) + ;; clear various flags + (setq teco-exp-flag1 nil + teco-at-flag nil + teco-colon-flag nil + teco-exp-flag1 nil))) + +(teco-define-type-2 + ?x ; x + (let* ((mm (teco-get-qspec nil (teco-get-command teco-trace))) + (args (teco-line-args 0)) + (text (buffer-substring (car args) (cdr args)))) + ;; if :, append to the register + (aset teco-qreg-text mm (if teco-colon-flag + (concat (aref teco-qreg-text mm) text) + text)) + ;; clear various flags + (setq teco-exp-flag1 nil + teco-at-flag nil + teco-colon-flag nil + teco-exp-flag1 nil))) + +(teco-define-type-2 + ?g ; g + (let ((mm (teco-get-qspec t (teco-get-command teco-trace)))) + (if teco-colon-flag + (teco-output (aref teco-qreg-text mm)) + (insert (aref teco-qreg-text mm))) + (setq teco-colon-flag nil))) + +(teco-define-type-2 + ?\[ ; \[ + (let ((mm (teco-get-qspec t (teco-get-command teco-trace)))) + (setq teco-qreg-stack + (cons (cons (aref teco-qreg-text mm) + (aref teco-qreg-number mm)) + teco-qreg-stack)))) + +(teco-define-type-2 + ?\] ; \] + (let ((mm (teco-get-qspec t (teco-get-command teco-trace)))) + (if teco-colon-flag + (setq teco-exp-flag1 t + teco-exp-val1 (if teco-qreg-stack -1 0)) + (if teco-qreg-stack + (let ((pop (car teco-qreg-stack))) + (aset teco-qreg-text mm (car pop)) + (aset teco-qreg-number mm (cdr pop)) + (setq teco-qreg-stack (cdr teco-qreg-stack))) + (teco-error "CPQ"))) + (setq teco-colon-flag nil))) + +(teco-define-type-2 + ?\\ ; \ + (if (not teco-exp-flag1) + ;; no argument; read number + (let ((p (point)) + (sign +1) + (n 0) + c) + (setq c (char-after p)) + (if c + (if (= c ?+) + (setq p (1+ p)) + (if (= c ?-) + (setq p (1+ p) + sign -1)))) + (cond + ((= teco-ctrl-r 8) + (while (progn + (setq c (char-after p)) + (and c (>= c ?0) (<= c ?7))) + (setq p (1+ p) + n (+ c -48 (* n 8))))) + ((= teco-ctrl-r 10) + (while (progn + (setq c (char-after p)) + (and c (>= c ?0) (<= c ?9))) + (setq p (1+ p) + n (+ c -48 (* n 10))))) + (t + (while (progn + (setq c (char-after p)) + (and c + (or + (and (>= c ?0) (<= c ?9)) + (and (>= c ?a) (<= c ?f)) + (and (>= c ?A) (<= c ?F))))) + (setq p (1+ p) + n (+ c (if (> c ?F) + ;; convert 'a' to 10 + -87 + (if (> c ?9) + ;; convert 'A' to 10 + -55 + ;; convert '0' to 0 + -48)) + (* n 16)))))) + (setq teco-exp-val1 (* n sign) + teco-exp-flag1 t + teco-ctrl-s (- (point) p))) + ;; argument: insert it as a digit string + (insert (format (cond + ((= teco-ctrl-r 8) "%o") + ((= teco-ctrl-r 10) "%d") + (t "%x")) + teco-exp-val1)) + (setq teco-exp-flag1 nil + teco-exp-op 'start))) + +(teco-define-type-2 + ?\C-t ; ^t + (if teco-exp-flag1 + ;; type a character + (progn + (teco-output teco-exp-val1) + (setq teco-exp-flag1 nil)) + ;; input a character + (let* ((echo-keystrokes 0) + (c (read-char))) + (teco-output c) + (setq teco-exp-val1 c + teco-exp-flag1 t)))) + +(teco-define-type-2 + ?s ; s + (let ((arg (teco-get-text-arg)) + (count (if teco-exp-flag1 teco-expr-val1 1)) + regexp) + (if (not (string-equal arg "")) + (setq regexp (teco-parse-search-string arg) + teco-last-search-string arg + teco-last-search-regexp regexp) + (setq regexp (teco-last-search-regexp) + arg teco-last-search-string)) + (let ((p (point)) + (result (cond + ((> count 0) + (re-search-forward regexp nil t count)) + ((< count 0) + (re-search-backward regexp nil t count)) + (t + ;; 0s always is successful + t)))) + ;; if ::s, restore point + (if (eq teco-colon-flag 2) + (goto-char p)) + ;; if no real or implied colon, error if not found + (if (and (not result) + (not teco-colon-flag) + (/= (teco-peekcmdc) 34)) + (teco-error "SRH")) + ;; set return results + (setq teco-exp-flag2 nil + teco-colon-flag nil + teco-at-flag nil + teco-exp-op 'start) + (if teco-colon-flag + (setq teco-exp-flag1 t + teco-exp-val1 (if result -1 0)) + (setq teco-exp-flag1 nil))))) + +(defun teco-parse-search-string (s) + (let ((i 0) + (l (length s)) + (r "") + c) + (while (< i l) + (setq r (concat r (teco-parse-search-string-1)))) + r)) + +(defun teco-parse-search-string-1 () + (if (>= i l) + (teco-error "ISS")) + (setq c (aref s i)) + (setq i (1+ i)) + (cond + ((eq c ?\C-e) ; ^E - special match characters + (teco-parse-search-string-e)) + ((eq c ?\C-n) ; ^Nx - match all but x + (teco-parse-search-string-n)) + ((eq c ?\C-q) ; ^Qx - use x literally + (teco-parse-search-string-q)) + ((eq c ?\C-s) ; ^S - match separator chars + "[^A-Za-z0-9]") + ((eq c ?\C-x) ; ^X - match any character + "[\000-\377]") + (t ; ordinary character + (teco-parse-search-string-char c)))) + +(defun teco-parse-search-string-char (c) + (regexp-quote (char-to-string c))) + +(defun teco-parse-search-string-q () + (if (>= i l) + (teco-error "ISS")) + (setq c (aref s i)) + (setq i (1+ i)) + (teco-parse-search-string-char c)) + +(defun teco-parse-search-string-e () + (if (>= i l) + (teco-error "ISS")) + (setq c (aref s i)) + (setq i (1+ i)) + (cond + ((or (eq c ?a) (eq c ?A)) ; ^EA - match alphabetics + "[A-Za-z]") + ((or (eq c ?c) (eq c ?C)) ; ^EC - match symbol constituents + "[A-Za-z.$]") + ((or (eq c ?d) (eq c ?D)) ; ^ED - match numerics + "[0-9]") + ((eq c ?g) ; ^EGq - match any char in q-reg + (teco-parse-search-string-e-g)) + ((or (eq c ?l) (eq c ?L)) ; ^EL - match line terminators + "[\012\013\014]") + ((eq c ?q) ; ^EQq - use contents of q-reg + (teco-parse-search-string-e-q)) + ((eq c ?r) ; ^ER - match alphanumerics + "[A-Za-z0-9]") + ((eq c ?s) ; ^ES - match non-null space/tab seq + "[ \t]+") + ((eq c ?v) ; ^EV - match lower case alphabetic + "[a-z]") + ((eq c ?w) ; ^EW - match upper case alphabetic + "[A-Z]") + ((eq c ?x) ; ^EX - match any character + "[\000-\377]") + (t + (teco-error "ISS")))) + +(defun teco-parse-search-string-e-q () + (if (>= i l) + (teco-error "ISS")) + (setq c (aref s i)) + (setq i (1+ i)) + (regexp-quote (aref reco:q-reg-text c))) + +(defun teco-parse-search-string-e-g () + (if (>= i l) + (teco-error "ISS")) + (setq c (aref s i)) + (setq i (1+ i)) + (let* ((q (aref teco-qreg-text c)) + (len (length q)) + (null (= len 0)) + (one-char (= len 1)) + (dash-present (string-match "-" q)) + (caret-present (string-match "\\^" q)) + (outbracket-present (string-match "]" q)) + p) + (cond + (null + "[^\000-\377]") + (one-char + (teco-parse-search-string-char c)) + (t + (while (setq p (string-match "^]\\^")) + (setq q (concat (substring q 1 p) (substring q (1+ p))))) + (concat + "[" + (if outbracket-present "]" "") + (if dash-present "---" "") + q + (if caret-present "^" "")))))) + +(defun teco-parse-search-string-n () + (let ((p (teco-parse-search-string-1))) + (cond + ((= (aref p 0) ?\[) + (if (= (aref p 1) ?^) + ;; complement character set + (if (= (length p) 4) + ;; complement of one character + (teco-parse-search-string-char (aref p 2)) + ;; complement of more than one character + (concat "[" (substring p 2))) + ;; character set - invert it + (concat "[^" (substring p 1)))) + ((= (aref p 0) ?\\) + ;; single quoted character + (concat "[^" (substring p 1) "]")) + (t + ;; single character + (if (string-equal p "-") + "[^---]" + (concat "[^" p "]")))))) + +(teco-define-type-2 + ?o ; o + (let ((label (teco-get-text-arg)) + (index (and teco-exp-flag1 teco-exp-val1))) + (setq teco-exp-flag1 nil) + ;; handle computed goto by extracting the proper label + (if index + (if (< index 0) + ;; argument < 0 is a noop + (setq label "") + ;; otherwise, find the n-th label (0-origin) + (setq label (concat label ",")) + (let ((p 0)) + (while (and (> index 0) + (setq p (string-match "," label p)) + (setq p (1+ p))) + (setq index (1- index))) + (setq q (string-match "," label p)) + (setq label (substring label p q))))) + ;; if the label is non-null, find the correct label + ;; start from beginning of iteration or macro, and look for tag + (setq teco-command-pointer + (if teco-iteration-stack + ;; if in iteration, start at beginning of iteration + (aref (car teco-iteration-stack) 0) + ;; if not in iteration, start at beginning of command or macro + 0)) + ;; search for tag + (catch 'label + (let ((level 0) + c p l) + ;; look for interesting things, including ! + (while t + (setq c (teco-skipto t)) + (cond + ((= c ?<) ; start of iteration + (setq level (1+ level))) + ((= c ?>) ; end of iteration + (if (= level 0) + (teco-pop-iter-stack t) + (setq level (1- level)))) + ((= c ?!) ; start of tag + (setq p (string-match "!" teco-command-string teco-command-pointer)) + (if (and p + (string-equal label (substring teco-command-string + teco-command-pointer + p))) + (progn + (setq teco-command-pointer (1+ p)) + (throw 'label nil)))))))))) + +(teco-define-type-2 + ?a ; :a + ;; 'a' must be used as ':a' + (if (and teco-exp-flag1 teco-colon-flag) + (let ((char (+ (point) teco-exp-val1))) + (setq teco-exp-val1 + (if (and (>= char (point-min)) + (< char (point-max))) + (char-after char) + -1) + teco-colon-flag nil)) + (teco-error "ILL"))) + + +;; Routines to get next character from command buffer +;; getcmdc0, when reading beyond command string, pops +;; macro stack and continues. +;; getcmdc, in similar circumstances, reports an error. +;; If pushcmdc() has returned any chars, read them first +;; routines type characters as read, if argument != 0. + +(defun teco-get-command0 (trace) + ;; get the next character + (let (char) + (while (not (condition-case nil + (setq char (aref teco-command-string teco-command-pointer)) + ;; if we've exhausted the string, pop the macro stack + ;; if we exhaust the macro stack, exit + (error (teco-pop-macro-stack) + nil)))) + ;; bump the command pointer + (setq teco-command-pointer (1+ teco-command-pointer)) + ;; trace, if requested + (and trace (teco-trace-type char)) + ;; return the character + char)) + +;; while (cptr.dot >= cptr.z) /* if at end of this level, pop macro stack +;; { +;; if (--msp < &mstack[0]) /* pop stack; if top level +;; { +;; msp = &mstack[0]; /* restore stack pointer +;; cmdc = ESC; /* return an ESC (ignored) +;; exitflag = 1; /* set to terminate execution +;; return(cmdc); /* exit "while" and return +;; } +;; } +;; cmdc = cptr.p->ch[cptr.c++]; /* get char +;; ++cptr.dot; /* increment character count +;; if (trace) type_char(cmdc); /* trace +;; if (cptr.c > CELLSIZE-1) /* and chain if need be +;; { +;; cptr.p = cptr.p->f; +;; cptr.c = 0; +;; } +;; return(cmdc); +;; } + + +(defun teco-get-command (trace) + ;; get the next character + (let ((char (condition-case nil + (aref teco-command-string teco-command-pointer) + ;; if we've exhausted the string, give error + (error + (teco-error (if teco-macro-stack "UTM" "UTC")))))) + ;; bump the command pointer + (setq teco-command-pointer (1+ teco-command-pointer)) + ;; trace, if requested + (and trace (teco-trace-type char)) + ;; return the character + char)) + +;; char getcmdc(trace) +;; { +;; if (cptr.dot++ >= cptr.z) ERROR((msp <= &mstack[0]) ? E_UTC : E_UTM); +;; else +;; { +;; cmdc = cptr.p->ch[cptr.c++]; /* get char +;; if (trace) type_char(cmdc); /* trace +;; if (cptr.c > CELLSIZE-1) /* and chain if need be +;; { +;; cptr.p = cptr.p->f; +;; cptr.c = 0; +;; } +;; } +;; return(cmdc); +;; } + + +;; peek at next char in command string, return 1 if it is equal +;; (case independent) to argument + +(defun teco-peek-command (arg) + (condition-case nil + (eq (aref teco-mapch-l (aref teco-command-string teco-command-pointer)) + (aref teco-mapch-l arg)) + (error nil))) + +;; int peekcmdc(arg) +;; char arg; +;; { +;; return(((cptr.dot < cptr.z) && (mapch_l[cptr.p->ch[cptr.c]] == mapch_l[arg])) ? 1 : 0); +;; } + +(defun teco-get-text-arg (&optional term-char default-term-char) + ;; figure out what the terminating character is + (setq teco-term-char (or term-char + (if teco-at-flag + (teco-get-command teco-trace) + (or default-term-char + ?\e))) + teco-at_flag nil) + (let ((s "") + c) + (while (progn + (setq c (teco-get-command teco-trace)) + (/= c teco-term-char)) + (setq s (concat s (char-to-string c)))) + s)) + + +;; Routines to manipulate the stacks + +;; Pop the macro stack. Throw to 'teco-exit' if the stack is empty. +(defun teco-pop-macro-stack () + (if teco-macro-stack + (let ((frame (car teco-macro-stack))) + (setq teco-macro-stack (cdr teco-macro-stack) + teco-command-string (aref frame 0) + teco-command-pointer (aref frame 1) + teco-exec-flags (aref frame 2) + teco-iteration-stack (aref frame 3) + teco-cond-stack (aref frame 4))) + (throw 'teco-exit nil))) + +;; Push the macro stack. +(defun teco-push-macro-stack () + (setq teco-macro-stack + (cons (vector teco-command-string + teco-command-pointer + teco-exec-flags + teco-iteration-stack + teco-cond-stack) + teco-macro-stack))) + +;; Pop the expression stack. +(defun teco-pop-exp-stack () + (let ((frame (car teco-exp-stack))) + (setq teco-exp-stack (cdr teco-exp-stack) + teco-exp-val1 (aref frame 0) + teco-exp-flag1 (aref frame 1) + teco-exp-val2 (aref frame 2) + teco-exp-flag2 (aref frame 3) + teco-exp-exp (aref frame 4) + teco-exp-op (aref frame 5)))) + +;; Push the expression stack. +(defun teco-push-exp-stack () + (setq teco-exp-stack + (cons (vector teco-exp-val1 + teco-exp-flag1 + teco-exp-val2 + teco-exp-flag2 + teco-exp-exp + teco-exp-op) + teco-exp-stack))) + +;; Pop the iteration stack +;; if arg t, exit unconditionally +;; else check exit conditions and exit or reiterate +(defun teco-pop-iter-stack (arg) + (let ((frame (car teco-iteration-stack))) + (if (or arg + (not (aref frame 1)) + ;; test against 1, since one iteration has already been done + (<= (aref frame 2) 1)) + ;; exit iteration + (setq teco-iteration-stack (cdr teco-iteration-stack)) + ;; continue with iteration + ;; decrement count + (aset frame 2 (1- (aref frame 2))) + ;; reset command pointer + (setq teco-command-pointer (aref frame 0))))) + +;; Push the iteration stack +(defun teco-push-iter-stack (pointer flag count) + (setq teco-iteration-stack + (cons (vector pointer + flag + count) + teco-iteration-stack))) + +(defun teco-find-enditer () + (let ((icnt 1) + c) + (while (> icnt 0) + (while (progn (setq c (teco-skipto)) + (and (/= c ?<) + (/= c ?>))) + (if (= c ?<) + (setq icnt (1+ icnt)) + (setq icnt (1- icnt))))))) + + +;; I/O routines + +(defvar teco-output-buffer (get-buffer-create "*Teco Output*") + "The buffer into which Teco output is written.") + +(defun teco-out-init () + ;; Recreate the teco output buffer, if necessary + (setq teco-output-buffer (get-buffer-create "*Teco Output*")) + (save-excursion + (set-buffer teco-output-buffer) + ;; get a fresh line in output buffer + (goto-char (point-max)) + (insert ?\n) + ;; remember where to start displaying + (setq teco-output-start (point)) + ;; clear minibuffer, in case we have to display in it + (save-window-excursion + (select-window (minibuffer-window)) + (erase-buffer)) + ;; if output is visible, position it correctly + (let ((w (get-buffer-window teco-output-buffer))) + (if w + (progn + (set-window-start w teco-output-start) + (set-window-point w teco-output-start)))))) + +(defun teco-output (s) + (let ((w (get-buffer-window teco-output-buffer)) + (b (current-buffer)) + (sw (selected-window))) + ;; Put the text in the output buffer + (set-buffer teco-output-buffer) + (goto-char (point-max)) + (insert s) + (let ((p (point))) + (set-buffer b) + (if w + ;; if output is visible, move the window point to the end + (set-window-point w p) + ;; Otherwise, we have to figure out how to display the text + ;; Has a newline followed by another character been added to the + ;; output buffer? If so, we have to make the output buffer visible. + (if (save-excursion + (set-buffer teco-output-buffer) + (backward-char 1) + (search-backward "\n" teco-output-start t)) + ;; a newline has been seen, clear the minibuffer and make the + ;; output buffer visible + (progn + (save-window-excursion + (select-window (minibuffer-window)) + (erase-buffer)) + (let ((pop-up-windows t)) + (pop-to-buffer teco-output-buffer) + (goto-char p) + (set-window-start w teco-output-start) + (set-window-point w p) + (select-window sw))) + ;; a newline has not been seen, add output to minibuffer + (save-window-excursion + (select-window (minibuffer-window)) + (goto-char (point-max)) + (insert s))))))) + +;; Output a character of tracing information +(defun teco-trace-type (c) + (teco-output (if (= c ?\e) + ?$ + c))) + +;; Report an error +(defun teco-error (code) + (let ((text (cdr (assoc code teco-error-texts)))) + (teco-output (concat (if (save-excursion (set-buffer teco-output-buffer) + (/= (point) teco-output-start)) + "\n" + "") + "? " code " " text)) + (beep) + (if debug-on-error (debug nil code text)) + (throw 'teco-exit nil))) + + +;; Utility routines + +;; copy characters from command string to buffer +(defun teco-moveuntil (string pointer terminate trace) + (let ((count 0)) + (condition-case nil + (while (/= (aref string pointer) terminate) + (and teco-trace (teco-trace-type (aref string pointer))) + (insert (aref string pointer)) + (setq pointer (1+ pointer)) + (setq count (1+ count))) + (error (teco-error (if teco-macro-stack "UTM" "UTC")))) + count)) + +;; Convert character to q-register name +;; If file-or-search is t, allow _, *, %, # +(defun teco-get-qspec (file-or-search char) + ;; lower-case char + (setq char (aref teco-mapch-l char)) + ;; test that it's valid + (if (= (logand (aref teco-qspec-valid char) (if file-or-search 2 1)) 0) + (teco-error "IQN")) + char) + +;; Set or get value of a variable +(defun teco-set-var (var) + (if teco-exp-flag1 + (progn + (if teco-exp-flag2 + ;; if two arguments, they they are <clear bits>, <set bits> + (set var (logior (logand (symbol-value var) (lognot teco-exp-val2)) + teco-exp-val1)) + ;; if one argument, it is the new value + (set var teco-exp-val1)) + ;; consume argument(s) + (setq teco-exp-flag2 nil + teco-exp-flag1 nil)) + ;; if no arguments, fetch the value + (setq teco-exp-val1 (symbol-value var) + teco-exp-flag1 t))) + +;; Get numeric argument +(defun teco-get-value (default) + (prog1 + (if teco-exp-flag1 + teco-exp-val1 + (if (eq teco-exp-op 'sub) + (- default) + default)) + ;; consume argument + (setq teco-exp-flag1 nil + teco-exp-op 'start))) + +;; Get argument measuring in lines +(defun teco-lines (r) + (- (save-excursion + (if (> r 0) + (if (search-forward "\n" nil t r) + (point) + (point-max)) + (if (search-backward "\n" nil t (- 1 r)) + (1+ (point)) + (point-min)))) + (point))) + +;; routine to handle args for K, T, X, etc. +;; if two args, 'char x' to 'char y' +;; if just one arg, then n lines (default 1) +(defun teco-line-args (arg) + (if teco-exp-flag2 + (cons teco-exp-val1 teco-exp-val2) + (cons (point) (+ (point) (teco-lines (if teco-exp-flag1 + teco-exp-val1 + 1)))))) + +;; routine to skip to next ", ', |, <, or > +;; skips over these chars embedded in text strings +;; stops in ! if argument is t +;; returns character found +(defun teco-skipto (&optional arg) + (catch 'teco-skip + (let (;; "at" prefix + (atsw nil) + ;; temp attributes + ta + ;; terminator + term + skipc) + (while t ; forever + (while (progn + (setq skipc (teco-get-command nil) + ta (aref teco-spec-chars skipc)) + ;; if char is ^, treat next char as control + (if (eq skipc ?^) + (setq skipc (logand 31 (teco-get-command nil)) + ta (aref teco-spec-chars skipc))) + (= (logand ta 51) 0)) ; read until something interesting + ; found + nil) + (if (/= (logand ta 32) 0) + (teco-get-command nil)) ; if command takes a Q spec, + ; skip the spec + (if (/= (logand ta 16) 0) ; sought char found: quit + (progn + (if (= skipc ?\") ; quote must skip next char + (teco-get-command nil)) + (throw 'teco-skip skipc))) + (if (/= (logand ta 1) 0) ; other special char + (cond + ((eq skipc ?@) ; use alternative text terminator + (setq atsw t)) + ((eq skipc ?\C-^) ; ^^ is value of next char + ; skip that char + (teco-get-command nil)) + ((eq skipc ?\C-a) ; type text + (setq term (if atsw (teco-get-command nil) ?\C-a) + atsw nil) + (while (/= (teco-get-command nil) term) + nil)) ; skip text + ((eq skipc ?!) ; tag + (if arg + (throw 'teco-skip skipc)) + (while (/= (teco-get-command nil) ?!) + nil)) ; skip until next ! + ((or (eq skipc ?e) + (eq skipc ?f)) ; first char of two-letter E or F + ; command + nil))) ; not implemented + (if (/= (logand ta 2) 0) ; command with a text + ; argument + (progn + (setq term (if atsw (teco-get-command nil) ?\e) + atsw nil) + (while (/= (teco-get-command nil) term) + nil) ; skip text + )))))) + + +(defvar teco-command-keymap + ;; This is what used to be (make-vector 128 'teco-command-self-insert) + ;; Oh well + (let ((map (make-keymap)) (n 127)) + (while (>= n 0) + (define-key map (if (< n 32) (list 'control (+ n 32)) n) + 'teco-command-self-insert) + (setq n (1- n))) + map) + "Keymap used while reading teco commands.") + +(define-key teco-command-keymap "\^g" 'teco-command-ctrl-g) +(define-key teco-command-keymap "\^m" 'teco-command-return) +(define-key teco-command-keymap "\^u" 'teco-command-ctrl-u) +(define-key teco-command-keymap "\e" 'teco-command-escape) +(define-key teco-command-keymap "\^?" 'teco-command-delete) + +(defvar teco-command-escapes nil + "Records where ESCs are, since they are represented in the command buffer +by $.") + +;;;###autoload +(defun teco-command () + "Read and execute a Teco command string." + (interactive) + (let* ((teco-command-escapes nil) + (command (catch 'teco-command-quit + (read-from-minibuffer teco-prompt nil + teco-command-keymap)))) + (if command + (progn + (while teco-command-escapes + (aset command (car teco-command-escapes) ?\e) + (setq teco-command-escapes (cdr teco-command-escapes))) + (setq teco-output-buffer (get-buffer-create "*Teco Output*")) + (save-excursion + (set-buffer teco-output-buffer) + (goto-char (point-max)) + (insert teco-prompt command)) + (teco-execute-command command))))) + +(defun teco-read-command () + "Read a teco command string from the user." + (let ((command (catch 'teco-command-quit + (read-from-minibuffer teco-prompt nil + teco-command-keymap))) + teco-command-escapes) + (if command + (while teco-command-escapes + (aset command (car teco-command-escapes ?\e)) + (setq teco-command-escapes (cdr teco-command-escapes)))) + command)) + +(defun teco-command-self-insert () + (interactive) + (insert last-command-char) + (if (not (pos-visible-in-window-p)) + (enlarge-window 1))) + +(defun teco-command-ctrl-g () + (interactive) + (beep) + (throw 'teco-command-quit nil)) + +(defun teco-command-return () + (interactive) + (setq last-command-char ?\n) + (teco-command-self-insert)) + +(defun teco-command-escape () + (interactive) + ;; Two ESCs in a row terminate the command string + (if (eq last-command 'teco-command-escape) + (throw 'teco-command-quit (buffer-string))) + (setq teco-command-escapes (cons (1- (point)) teco-command-escapes)) + (setq last-command-char ?$) + (teco-command-self-insert)) + +(defun teco-command-ctrl-u () + (interactive) + ;; delete the characters + (kill-line 0) + ;; forget that they were ESCs + (while (and teco-command-escapes (<= (point) (car teco-command-escapes))) + (setq teco-command-escapes (cdr teco-command-escapes))) + ;; decide whether to shrink the window + (while (let ((a (insert ?\n)) + (b (pos-visible-in-window-p)) + (c (backward-delete-char 1))) + b) + (shrink-window 1))) + +(defun teco-command-delete () + (interactive) + ;; delete the character + (backward-delete-char 1) + ;; forget that it was an ESC + (if (and teco-command-escapes (= (point) (car teco-command-escapes))) + (setq teco-command-escapes (cdr teco-command-escapes))) + ;; decide whether to shrink the window + (insert ?\n) + (if (prog1 (pos-visible-in-window-p) + (backward-delete-char 1)) + (shrink-window 1))) + +(provide 'teco) + +;;; teco.el ends here