Article View: alt.lang.teco
Article #14teco.el - version 6 beta
From: Dale R. Worley
Date: Wed, 18 Nov 1992 20:10
Date: Wed, 18 Nov 1992 20:10
2365 lines
71777 bytes
71777 bytes
This is a beta test of version 6 of teco.el. The major difference
from version 5 is the addition of the ES flag to control the placement
of the point after an S with a negative argument. (If bit 1 is set,
the point is left at the end of the string, if clear, point is left at
the beginning of the string.) Since the various major versions of
Teco disagree on this feature, a controllable flag is needed to
maintain compatibility.
Also there are various bug fixes and the new commands:
nFW move over or delete n words
n,mL motion command to be used with FW
FE execute string as Emacs lisp command
teco:copy-to-q-reg
copy the region into a q-reg
Please send all bug reports and comments to:
Dale Worley Dept. of Math., MIT drw@math.mit.edu
--
;;; Teco interpreter for Gnu Emacs, version 6 beta.
;; LCD Archive Entry:
;; teco|Dale R. Worley|drw@math.mit.edu
;; |Teco interpreter
;; |92-11-18|version 6 beta|~/packages/teco.el.Z
(require 'backquote)
(provide 'teco)
;; This code has been tested some, but no doubt contains a zillion bugs.
;; You have been warned.
;; Some byte-compilers will not compile the function definitions for the
;; Teco commands because the defuns are created by macros. If you have this
;; problem, I can send you the byte-compiled version.
;; 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.
;; WARRANTY DISCLAIMER
;; This software was created by Dale R. Worley and is
;; distributed free of charge. It is placed in the public domain and
;; permission is granted to anyone to use, duplicate, modify and redistribute
;; it provided that this notice is attached.
;; Dale R. Worley provides absolutely NO WARRANTY OF ANY KIND
;; with respect to this software. The entire risk as to the quality and
;; performance of this software is with the user. IN NO EVENT WILL DALE R.
;; WORLEY BE LIABLE TO ANYONE FOR ANY DAMAGES ARISING OUT THE
;; USE OF THIS SOFTWARE, INCLUDING, WITHOUT LIMITATION, DAMAGES RESULTING FROM
;; LOST DATA OR LOST PROFITS, OR FOR ANY SPECIAL, INCIDENTAL OR CONSEQUENTIAL
;; DAMAGES.
;; 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.
;; Change log:
;; Version 1
;; Original implementation
;; Version 2
;; Fix bugs found by Alan Katz in S.
;; Version 3
;; Fix bugs found by Lum Johnson in key-binding code.
;; Fix handling of ^C, ^G, and ^L in command input.
;; Fix <...> so it iterates indefinitely. (Found by Mark Henderson.)
;; Fix ; so it exits from iterations correctly.
;; Add FR and FS commands.
;; Make commands that are supposed to set ^S do so.
;; Make flow-control commands clear the @-flag, so the @-flag can be
;; statically predicted during skipping of code.
;; Set up immediate-action commands ?, /, and *q.
;; Version 4
;; The T, D, and K commands weren't clearing their arguments.
;; Since ! is a flow-control command (O can go to it), it must clear the
;; @-flag.
;; Version 5
;; Fix bug found by karl@ima.ics.com in teco:output, causing trace output
;; to generate errors. It also caused =, ==, and === operators to generate
;; errors.
;; Put in improved disclaimer of copyright and warranty.
;; Added teco:version variable and function.
;; Version 6
;; Add attribution to "Philosophy".
;; Fix handling of negative arguments to S. (Fix due to Bill Freeman.)
;; Fix order of arguments produced by ^Y. (Fix due to Bill Freeman.)
;; Add ES flag to control placement of cursor after reverse searches.
;; (because different Tecos handle cursor placement differently)
;; Altered expression computation so that "-" alone yields -1 as a value.
;; (useful for -Sabc$)
;; Add n,mL command, mostly for use with FW.
;; Add FW command.
;; Add FR and FS to list of commands.
;; Add FE to execute Emacs lisp code.
;; Add teco:copy-to-q-reg to make loading q-regs easier.
;; To be able to invoke Teco directly, do:
;; (global-set-key "\C-z" 'teco:command)
;; ; or whatever key binding you want
;; (autoload 'teco:command "teco"
;; "Read and execute a Teco command string."
;; t nil)
;; This can be useful for loading q-regs from an Emacs buffer:
;; (global-set-key "\C-xy" 'teco:copy-to-q-reg)
;; ; or whatever key binding you want
;; (autoload 'teco:copy-to-q-reg "teco"
;; "Copy region into Teco q-reg REG."
;; 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.
;; Immediate action commands are ?, /, and *q.
;; Command set:
;; NUL Not a command.
;; ^A Output message to terminal (argument ends with ^A)
;; ^C Exit macro
;; ^C^C Stop execution
;; ^C (type-in) abort command
;; ^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 (type-in) abort command
;; TAB Insert tab and text
;; LF Line terminator; Ignored in commands
;; VT Ignored in commands
;; FF Ignored in commands
;; FF (type-in) redraw screen
;; CR Ignored in commands
;; ^Nx (match char) Match all but x
;; ^O Set radix to octal
;; ^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)
;; set by S, I, TAB, G, FR, FS, and \
;; ^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
;; *q (immediate action) Copy last command into q-reg
;; + Addition
;; , Argument separator
;; - Subtraction or negation
;; . Current pointer position
;; / Division
;; / (immediate action) Insert last command into command buffer
;; 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
;; ? Toggle tracing
;; ? (immediate action) Insert command string or macro that reported
;; last error, up to point of error, into command buffer
;; 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
;; ET Typeout control flag
;; 8 no echo for ^T
;; 32 no wait for ^T
;; ES Search control flag
;; 1 leave pointer at end of found string
;; after reverse search, rather than at beginning
;; FE Execute text argument as Emacs lisp. Uses string chars but
;; not match chars, so FE^EQq$ executes contents of q-reg
;; FR Replace string found by previous match with text argument
;; FSaaa$bbb$
;; Search for string aaa and replace it with bbb.
;; nFW Return arguments .,n where n is the other side of the n-th
;; word from point. Main uses: FWL moves right one word,
;; -FWL moves left one word, FWK deletes one word to right,
;; nFWXq puts n words into q-reg
;; "word" is defined by Emacs' syntax table
;; :FW Like FW, but goes to near side of the n-th word
;; 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
;; n,mL Same as n+m-.J, mostly for use by FW.
;; 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
;; W Redraw the display
;; nW Put point on line n of the display
;; 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
;; Special q-register names:
;;
;; _ last search string
;; # the current command string
;; * last command string
;; % the last command string or macro that returned an error,
;; to the point at which the error was found
;; Philosophy:
;; Real programmers don't want "what you see is what you get", they want
;; "you asked for it, you got it". They want editors that are terse,
;; powerful, cryptic, and unforgiving. In a word, Teco.
;; after Ed Post, "Real Programmers Don't Use Pascal", in Datamation,
;; July 1983, p. 264
;; The version number
(defvar teco-version "6"
"The version of Teco.")
(defun teco-version ()
"Return string describing the version of Teco. When called interactively,
displays the version."
(interactive)
(if (interactive-p)
(message "Teco version %s" (teco-version))
teco-version))
;; 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:et-flag 0
"ET flags:
8 do not echo ^T input
32 do not wait for ^T input if no character is available.")
(defvar teco:es-flag 0
"ES flags:
1 leave pointer at end of found string after reverse search,
rather than at beginning.")
(defvar teco:ctrl-s 0
"The negative of the length of the last string inserted or searched for.
Set by the S, I, TAB, G, FR, FS, and \\ commands.")
(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: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-regexp ""
"Regexp version of last search string (q-reg '_').")
(defvar teco:search-result 0
"Result of the last search.")
(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 or text 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 1025 1040 0 ; ! \" #
0 0 0 1040; $ % & '
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 : ;
1040 0 1040 0 ; < = > ?
1 0 12 0 ; @ A B C
0 9 1 32 ; D E F G
0 2 0 0 ; H I J K
0 32 10 1026; L M N O
0 32 8 514 ; P Q R S
0 32 0 4 ; T U V W
32 0 0 32 ; X Y Z \[
0 32 1 2 ; \ \] ^ _
0 0 12 0 ; ` a b c
0 9 1 32 ; d e f g
0 2 0 0 ; h i j k
0 32 10 1026; l m n o
0 32 8 514 ; 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
256 command with a double text argument
512 F<char> takes a double text argument
1024 transfer of control command")
(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:iteration-stack nil)
(teco:cond-stack nil)
(teco:exp-stack nil)
(teco:macro-stack nil)
(teco:qreg-stack nil)
(teco:search-result 0))
;; save command string
(aset teco:qreg-text ?* (aref teco:qreg-text ?#))
(aset teco:qreg-text ?# string)
;; 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)))
;; a solitary '-' yields -1
(if (eq teco:exp-op 'sub)
(setq teco:exp-val1 -1
teco:exp-op 'start
teco:exp-flag1 t)))
;; 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)
(setq teco:at-flag 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:exp-val2 (+ (point) teco:ctrl-s)
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
?\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, which is case-fold-search
(let ((x-flag (if case-fold-search 0 -1)))
(teco:set-var 'x-flag)
(setq case-fold-search (= x-flag 0))))
(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:at-flag 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:at-flag nil))
(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 ?\')))
nil)
(if (= c ?\")
(setq ll (1+ ll))
(if (= c ?\')
(setq ll (1- ll))
(if (= ll 1)
(break)))))))
;; clear at-flag
(setq teco:at-flag nil)))
(teco:define-type-2
?' ; '
;; no effect if executing
;; clear at-flag
(setq teco:at-flag nil))
(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-flag1 nil
teco:exp-flag2 nil))))
(teco:define-type-2
?l ; l
;; move forward by lines
(let* ((ll (teco:line-args 1))
(p (+ (car ll) (cdr ll) (- (point)))))
(if (or (< p (point-min)) (> p (point-max)))
(teco:error "POP")
(goto-char p)
(setq teco:exp-flag1 nil
teco:exp-flag2 nil))))
(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))))
;; clear various flags
(setq teco:exp-flag1 nil))
(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)))
;; clear various flags
(setq teco:exp-flag1 nil
teco:exp-flag2 nil)))
(teco:define-type-2
?k ; k
(let ((ll (teco:line-args 1)))
(delete-region (car ll) (cdr ll)))
;; clear various flags
(setq teco:exp-flag1 nil
teco:exp-flag2 nil))
(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: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))
(let ((text (aref teco:qreg-text mm)))
(insert text)
(setq teco:ctrl-s (- (length text)))))
(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
(if (or (= (logand teco:et-flag 32) 0)
(input-pending-p))
;; input is pending, or we must wait
(let* ((echo-keystrokes 0)
(c (read-char)))
(if (= (logand teco:et-flag 8) 0)
(teco:output c))
(setq teco:exp-val1 c
teco:exp-flag1 t))
;; no input is pending, and ET bit 32 is set
(setq teco:exp-val1 -1
teco:exp-flag1 t))))
(teco:define-type-2
?w ; w
(if teco:exp-flag1
(progn
(recenter teco:exp-val1)
(setq teco:exp-flag1 nil))
(redraw-display)))
(teco:define-type-2
?s ; s
(let ((arg (teco:get-text-arg))
(count (if teco:exp-flag1 teco:exp-val1 1))
regexp)
(if (string-equal arg "")
;; Retrieve last search string
(setq regexp teco:last-search-regexp
arg (aref teco:qreg-text ?_))
;; Store this search string
(setq regexp (teco:parse-search-string arg)
teco:last-search-regexp regexp)
(aset teco:qreg-text ?_ arg))
(let ((result (cond
((eq teco:colon-flag 2)
(looking-at regexp))
((> count 0)
(re-search-forward regexp nil t count))
((< count 0)
(re-search-backward regexp nil t (- count)))
(t
;; 0s is always successful
t))))
(if (and result
(< count 0)
(= (logand teco:es-flag 1) 1))
(goto-char (match-end 0)))
;; set ctrl-s, if the match was successful
(if (and result
(or (/= count 0) (eq teco:colon-flag 2)))
(setq teco:ctrl-s (- (match-beginning 0) (match-end 0))))
;; save result for later ';'
(setq teco:search-result (if result -1 0))
;; if no real or implied colon, error if not found
(if (and (not result)
(not teco:colon-flag)
(not (teco:peek-command 59)))
(teco:error "SRH"))
;; set return results
(if teco:colon-flag
(setq teco:exp-flag1 t
teco:exp-val1 teco:search-result)
(setq teco:exp-flag1 nil))
;; clear other flags
(setq teco:exp-flag2 nil
teco:colon-flag nil
teco:at-flag nil
teco:exp-op 'start))))
(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 "]"))))))
(defun teco:substitute-text-string (s)
(let ((i 0)
(l (length s))
(r "")
c)
(while (< i l)
(setq r (concat r (teco:substitute-text-string-1))))
r))
(defun teco:substitute-text-string-1 ()
(if (>= i l)
(teco:error "ISS"))
(setq c (aref s i))
(setq i (1+ i))
(cond
((eq c ?\C-e) ; ^E - special string characters
(teco:substitute-text-string-e))
((eq c ?\C-q) ; ^Qx - use x literally
(teco:substitute-text-string-q))
(t ; ordinary character
(char-to-string c))))
(defun teco:substitute-text-string-q ()
(if (>= i l)
(teco:error "ISS"))
(setq c (aref s i))
(setq i (1+ i))
(char-to-string c))
(defun teco:substitute-text-string-e ()
(if (>= i l)
(teco:error "ISS"))
(setq c (aref s i))
(setq i (1+ i))
(cond
((eq c ?q) ; ^EQq - use contents of q-reg
(teco:substitute-text-string-e-q))
(t
(teco:error "ISS"))))
(defun teco:substitute-text-string-e-q ()
(if (>= i l)
(teco:error "ISS"))
(setq c (aref s i))
(setq i (1+ i))
(aref reco:q-reg-text c))
(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")))
(teco:define-type-2
?e ; e
(let ((c (teco:get-command teco:trace)))
(cond
((= c ?t) (teco:set-var 'teco:et-flag))
((= c ?s) (teco:set-var 'teco:es-flag))
(t (teco:error "IEC")))))
(teco:define-type-2
?f ; f
(let ((c (teco:get-command teco:trace)))
(cond
((= c ?e) (teco:fe-command))
((= c ?r) (teco:fr-command))
((= c ?s) (teco:fs-command))
((= c ?w) (teco:fw-command))
(t (teco:error "IFC")))))
(defun teco:fe-command () ; fe
(let ((text (teco:substitute-text-string (teco:get-text-arg))))
(prin1-to-string (eval (read text)))))
(defun teco:fr-command () ; fr
(let ((text (teco:get-text-arg)))
;; delete the previous match
(delete-char teco:ctrl-s)
;; insert the argument
(insert text)
;; set ^S for the insertion
(setq teco:ctrl-s (- (length text)))))
(defun teco:fs-command () ; fs
(let* ((args (teco:get-two-text-args))
(search (car args))
(replace (car (cdr args)))
regexp)
(if (string-equal search "")
;; Retrieve last search string
(setq regexp teco:last-search-regexp
search (aref teco:qreg-text ?_))
;; Store this search string
(setq regexp (teco:parse-search-string search)
teco:last-search-regexp regexp)
(aset teco:qreg-text ?_ search))
(let ((result (re-search-forward regexp nil t)))
;; save result for later ';'
(setq teco:search-result (if result -1 0))
;; if no real or implied colon, error if not found
(if (and (not result)
(not teco:colon-flag)
(not (teco:peek-command 59)))
(teco:error "SRH"))
;; set return results
(if teco:colon-flag
(setq teco:exp-flag1 t
teco:exp-val1 teco:search-result)
(setq teco:exp-flag1 nil))
;; clear other flags
(setq teco:exp-flag2 nil
teco:colon-flag nil
teco:at-flag nil
teco:exp-op 'start)
(if result
(progn
;; delete the match
(delete-backward-char (- (match-end 0) (match-beginning 0)))
;; insert the argument
(insert replace)
;; set ^S for the insertion
(setq teco:ctrl-s (- (length replace))))))))
(defun teco:fw-command () ; fw
(let ((count (teco:get-value 1))
(start (point)))
;; argument 0 is a no-op
(if (/= count 0)
(progn
(forward-word count)
;; If : is present, back off to the near side of the last word
;; found. Make sure we don't run past the starting position.
(if teco:colon-flag
(if (> count 0)
;; Searching forward
(progn
(forward-word -1)
(if (< (point) start)
(goto-char start)))
;; Searching backward
(progn
(forward-word 1)
(if (> (point) start)
(goto-char start)))))))
;; get the result values into the arguments
(setq teco:exp-val2 start
teco:exp-flag2 t
teco:exp-val1 (point)
teco:exp-flag1 t
teco:colon-flag nil)
;; don't move the point
(goto-char start)))
;; 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))
(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))
;; 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)))
(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))
(defun teco:get-two-text-args (&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 ((s1 "")
(s2 "")
c)
(while (progn
(setq c (teco:get-command teco:trace))
(/= c teco:term-char))
(setq s1 (concat s1 (char-to-string c))))
(while (progn
(setq c (teco:get-command teco:trace))
(/= c teco:term-char))
(setq s2 (concat s2 (char-to-string c))))
(list s1 s2)))
;; 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:iteration-stack (aref frame 2)
teco:cond-stack (aref frame 3)
teco:at-flag nil))
(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: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
(and ;; without argument, iterate indefinitely
(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
(and (aref frame 1)
(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)
;; Do no work if output is "". Also, this avoids an error condition.
(if (not (and (stringp s) (string-equal 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)
;; save the command with the error
(aset teco:qreg-text ?%
(substring teco:command-string 0 teco:command-pointer))
(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
;; Convert character to q-register name
;; If file-or-search is t, allow special q-reg names
(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))
(cond
;; if char is ^, treat next char as control
((eq skipc ?^)
(setq skipc (logand 31 (teco:get-command nil))
ta (aref teco:spec-chars skipc)))
;; if char is E or F, pick up next char and interpret the
;; two-character sequence
((eq skipc ?e)
(setq skipc (teco:get-command nil)
ta (logand -259 (aref teco:spec-chars skipc)))
(if (/= (logand ta 4) 0)
(setq ta (logior ta 2))))
((eq skipc ?f)
(setq skipc (teco:get-command nil)
ta (logand -259 (aref teco:spec-chars skipc)))
(if (/= (logand ta 8) 0)
(setq ta (logior ta 2)))
(if (/= (logand ta 512) 0)
(setq ta (logior ta 256)))))
(= (logand ta 307) 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
))
(if (/= (logand ta 256) 0) ; command with a double text
; argument
(progn
(setq term (if atsw (teco:get-command nil) ?\e)
atsw nil)
(while (/= (teco:get-command nil) term)
nil) ; skip text
(while (/= (teco:get-command nil) term)
nil) ; skip second text
(if (/= (logand ta 1024) 0)
(setq atsw nil)) ; transfer command clears @-flag
; after executing
))))))
(defun teco:set-var (variable)
;; If there is an argument, then set the variable
(if teco:exp-flag1
(progn
(set variable
(if teco:exp-flag2
;; If there are two arguments, then they are bits to clear
;; and bits to set
(logior (logand (lognot (symbol-value variable))
teco:exp-val2) teco:exp-val1)
;; One argument is the new value
teco:exp-val1))
(setq teco:exp-flag1 nil
teco:exp-flag2 nil))
;; No arguments mean to fetch the variable's value
(setq teco:exp-val1 (symbol-value variable)
teco:exp-flag1 t)))
;; Input handling
(defvar teco:command-keymap (make-vector 128 'teco:command-self-insert)
"Keymap used while reading teco commands.")
(define-key teco:command-keymap "\^c" 'teco:command-quit)
(define-key teco:command-keymap "\^g" 'teco:command-quit)
(define-key teco:command-keymap "\^l" 'teco:command-ctrl-l)
(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)
(define-key teco:command-keymap "?" 'teco:command-query)
(define-key teco:command-keymap "/" 'teco:command-slash)
(define-key teco:command-keymap "*" 'teco:command-star)
(defvar teco:command-escapes nil
"Records where ESCs are, since they are represented in the command buffer
by $.")
(defun teco:copy-to-q-reg (char start end)
"Copy region into Teco q-reg REG.
When called from program, takes three args: REG, START, and END.
START and END are buffer positions indicating what to copy."
(interactive "cCopy region to q-reg: \nr")
(setq char (aref teco:mapch-l char))
;; test that it's valid
(if (= (logand (aref teco:qspec-valid char) 1) 0)
(error "? IQN Invalid Q-reg name"))
(aset teco:qreg-text char (buffer-substring start end)))
(defun teco:command ()
"Read and execute a Teco command string."
(interactive)
(let ((command (teco:read-command)))
(if command
(progn
(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)))))
(fset 'teco (symbol-function 'teco:command))
(defun teco:read-command ()
"Read a teco command string from the user."
(let* ((teco:command-escapes nil)
(command (catch 'teco:command-quit
(read-from-minibuffer teco:prompt nil
teco:command-keymap))))
(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)
(teco:command-insert-character last-command-char))
(defun teco:command-quit ()
(interactive)
(beep)
(throw 'teco:command-quit nil))
(defun teco:command-ctrl-l ()
(interactive)
(redraw-display))
(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)))
(teco:command-insert-character last-command-char))
(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 (= (1- (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)))
(defun teco:command-query ()
(interactive)
;; first input char sees last-command equal to 't
(if (eq last-command t)
;; if first character of command, insert erroneous command
(let* ((s (aref teco:qreg-text ?%))
(l (length s))
(i 0))
(while (< i l)
(teco:command-insert-character (aref s i))
(setq i (1+ i))))
;; otherwise, just insert the character
(teco:command-self-insert)))
(defun teco:command-slash ()
(interactive)
;; first input char sees last-command equal to 't
(if (eq last-command t)
;; if first character of command, insert last command
(let* ((s (aref teco:qreg-text ?#))
(l (length s))
(i 0))
(while (< i l)
(teco:command-insert-character (aref s i))
(setq i (1+ i))))
;; otherwise, just insert the character
(teco:command-self-insert)))
(defun teco:command-star ()
(interactive)
;; first input char sees last-command equal to 't
(if (eq last-command t)
;; if first character of command, offer to save previous command in
;; q-register
(progn
;; insert the * into the buffer
(teco:command-insert-character last-command-char)
;; read the next character
(let ((c (read-char))
c1)
(setq xxx1 c)
;; test if it is a valid q-reg name
(setq c1 (aref teco:mapch-l c))
(setq xxx2 c1)
(if (/= (logand (aref teco:qspec-valid c1) 1) 0)
;; if so, store the command, give a message, and abort command
(progn
(aset teco:qreg-text c1 (aref teco:qreg-text ?#))
(message "Last Teco command stored in q-register %c" c1)
(throw 'teco:command-quit nil))
;; if q-reg name is invalid, just insert the character
(beep)
(teco:command-insert-character c))))
;; otherwise, just insert the character
(teco:command-self-insert)))
;; Insert a single command character
(defun teco:command-insert-character (c)
(if (eq c ?\e)
(setq teco:command-escapes (cons (1- (point)) teco:command-escapes)
c ?$))
(insert c)
(if (not (pos-visible-in-window-p))
(enlarge-window 1)))
Technical Details
Message-ID:
<DRW.92Nov18151051@euclid.mit.edu>Path:
arc1-ca.pugleaf.net!sparky!uunet!snorkelwacker.mit.edu!bloom-picayune.mit.edu!math.mit.edu!drwShow Full Headers
Complete Article Headers
Newsgroups: alt.lang.teco Path: arc1-ca.pugleaf.net!sparky!uunet!snorkelwacker.mit.edu!bloom-picayune.mit.edu!math.mit.edu!drw From: drw@euclid.mit.edu (Dale R. Worley) Subject: teco.el - version 6 beta Message-ID: <DRW.92Nov18151051@euclid.mit.edu> Sender: news@athena.mit.edu (News system) Nntp-Posting-Host: euclid.mit.edu Organization: MIT Dept. of Tetrapilotomy, Cambridge, MA, USA Date: Wed, 18 Nov 1992 20:10:51 GMT Lines: 2365