Download
(require 'backquote)
(provide 'teco)
(defvar teco-version "7"
"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))
(defun teco:set-elements (array start end value)
(let ((i start))
(while (<= i end)
(aset array i value)
(setq i (1+ i)))))
(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
0 64 0 0
0 2 128 128
128 0 64 0
0 64 64 64
0 34 0 0
64 0 0 0
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 0 0 0
0 0 0 0
1040 0 1040 0
1 0 12 0
0 9 1 32
0 2 0 0
0 32 10 1026
0 32 8 514
0 32 0 4
32 0 0 32
0 32 1 2
0 0 12 0
0 9 1 32
0 2 0 0
0 32 10 1026
0 32 8 514
0 32 0 4
32 0 0 0
16 0 0 0
]
"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."
(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))
(aset teco:qreg-text ?* (aref teco:qreg-text ?#))
(aset teco:qreg-text ?# string)
(teco:out-init)
(catch 'teco:exit
(while t
(let ((cmdc (teco:get-command0 teco:trace)))
(if (eq cmdc ?^)
(setq cmdc (logand (teco:get-command teco:trace) 31)))
(if (and (<= ?0 cmdc) (<= cmdc ?9))
(progn
(setq cmdc (- cmdc ?0))
(if (>= cmdc teco:ctrl-r)
(teco:error "ILN"))
(if teco:digit-switch
(setq teco:exp-val1
(+ (* teco:exp-val1 teco:ctrl-r) cmdc))
(setq teco:exp-val1 cmdc)
(setq teco:digit-switch t))
(setq teco:exp-flag1 t))
(setq teco:digit-switch nil)
(setq cmdc (aref teco:mapch-l cmdc))
(let ((r (aref teco:exec-1 cmdc)))
(if r
(funcall r)
(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)))
(if (eq teco:exp-op 'sub)
(setq teco:exp-val1 -1
teco:exp-op 'start
teco:exp-flag1 t)))
(let ((r (aref teco:exec-2 cmdc)))
(if r
(funcall r)
(teco:error "ILL")))))))))))
(teco:define-type-1
?\^m
nil)
(teco:define-type-1
?\n
nil)
(teco:define-type-1
?\^k
nil)
(teco:define-type-1
?\^l
nil)
(teco:define-type-1
32
nil)
(teco:define-type-1
?\e
(if (teco:peek-command ?\e)
(teco:pop-macro-stack)
(setq teco:exp-flag1 nil
teco:exp-flag2 nil
teco:exp-op 'start)))
(teco:define-type-1
?!
(while (/= (teco:get-command teco:trace) ?!)
nil)
(setq teco:at-flag nil))
(teco:define-type-1
?@
(setq teco:at-flag t))
(teco:define-type-1
?:
(if (teco:peek-command ?:)
(progn
(teco:get-command teco:trace)
(setq teco:colon-flag 2))
(setq teco:colon-flag 1)))
(teco:define-type-1
??
(setq teco:trace (not teco:trace)))
(teco:define-type-1
?.
(setq teco:exp-val1 (point)
teco:exp-flag1 t))
(teco:define-type-1
?z
(setq teco:exp-val1 (point-max)
teco:exp-flag1 t))
(teco:define-type-1
?b
(setq teco:exp-val1 (point-min)
teco:exp-flag1 t))
(teco:define-type-1
?h
(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
(setq teco:exp-val1 teco:ctrl-s
teco:exp-flag1 t))
(teco:define-type-1
?\^y
(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
?\(
(teco:push-exp-stack)
(setq teco:exp-flag1 nil
teco:exp-flag2 nil
teco:exp-op 'start))
(teco:define-type-1
?\C-^
(setq teco:exp-val1 (teco:get-command teco:trace)
teco:exp-flag1 t))
(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
(setq teco:ctrl-r 10
teco:exp-flag1 nil
teco:exp-op 'start))
(teco:define-type-2
?\^o
(setq teco:ctrl-r 8
teco:exp-flag1 nil
teco:exp-op 'start))
(teco:define-type-2
?\^r
(if teco:colon-flag
(progn
(recursive-edit)
(setq teco:colon-flag nil))
(if teco:exp-flag1
(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))
(setq teco:exp-val1 teco:ctrl-r
teco:exp-flag1 t))))
(teco:define-type-2
?\^c
(if (teco:peek-command ?\^c)
(throw 'teco:exit nil)
(if teco:macro-stack
(teco:pop-macro-stack)
(throw 'teco:exit nil))))
(teco:define-type-2
?\^x
(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
(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
?<
(if (and teco:exp-flag1 (<= teco:exp-val1 0))
(teco:find-enditer)
(teco:push-iter-stack teco:command-pointer
teco:exp-flag1 teco:exp-val1)
(setq teco:exp-flag1 nil
teco:at-flag nil)))
(teco:define-type-2
?>
(if (not teco:iteration-stack)
(teco:error "BNI"))
(teco:pop-iter-stack nil)
(setq teco:exp-flag1 nil
teco:exp-flag2 nil
teco:exp-op 'start
teco:at-flag nil))
(teco:define-type-2
59
(if (not teco:iteration-stack)
(teco:error "SNI"))
(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)))
(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 '
;; ll counts the number of conditionals we are inside of
(let ((ll 1)
c)
(while (> ll 0)
;; skip to the next significant character
(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)
(setq ll 0) ; for immediate exit if | at ll=1
))))))
;; 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))
(p (+ (car ll) (cdr ll) (- (point)))))
(if (or (< p (point-min)) (> p (point-max)))
(teco:error "POP")
(goto-char p))))
(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 teco: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)))
(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)))
(delete-region (car ll) (cdr ll)))))
(teco:define-type-2
?k ; k
(let ((ll (teco:line-args)))
(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))
(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: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))
(goto-char 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 teco: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 teco: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)
q)
(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 ?l) (teco:fl-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:fl-command () ; fl
(let ((count (teco:get-value 1))
(start (point)))
;; argument 0 is a no-op
(if (/= count 0)
(forward-sexp count))
;; 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)))
(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"
"")
;; due to the test in teco:output and Emacs' handling
;; of trailing newlines in the minibuffer-window,
;; we can have a newline at the end of the error
;; message and it will not force the output display
;; from the minibuffer into the Teco output buffer
"? " code " " text "\n"))
(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 (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 alone
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)))
;; 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 ()
(prog1
(if teco:exp-flag2
(cons teco:exp-val1 teco:exp-val2)
(cons (point) (+ (point) (teco:lines (if teco:exp-flag1
teco:exp-val1
1)))))
(setq teco:exp-flag1 nil
teco:exp-flag2 nil)))
;; routine to skip to next ", ', |, <, or >
(defun teco:skipto (&optional arg)
(catch 'teco:skip
(let (
(atsw nil)
ta
term
skipc)
(while t
(while (progn
(setq skipc (teco:get-command nil)
ta (aref teco:spec-chars skipc))
(cond
((eq skipc ?^)
(setq skipc (logand 31 (teco:get-command nil))
ta (aref teco:spec-chars skipc)))
((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))
nil)
(if (/= (logand ta 32) 0)
(teco:get-command nil))
(if (/= (logand ta 16) 0)
(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
))))))
;; Input handling
(defvar teco:command-keymap
(list '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)
;; test if it is a valid q-reg name
(setq c1 (aref teco:mapch-l c))
(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)))
;;; teco.el ends here