├── .gitignore
├── 3bst.asd
├── LICENSE
├── README.md
├── bindings.lisp
├── package.lisp
└── st.lisp


/.gitignore:
--------------------------------------------------------------------------------
1 | *~
2 | *.fasl


--------------------------------------------------------------------------------
/3bst.asd:
--------------------------------------------------------------------------------
 1 | (defsystem 3bst
 2 |   :description "CL port of the terminal emulation part of st (http://st.suckless.org/)"
 3 |   :depends-on (#:alexandria
 4 |                #:split-sequence)
 5 |   :license "MIT"
 6 |   :author "Bart Botta <00003b at gmail.com>"
 7 |   :serial t
 8 |   :components
 9 |   ((:file "package")
10 |    (:file "st")
11 |    (:file "bindings")))
12 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | MIT/X Consortium License
 2 | 
 3 | Original C version
 4 | © 2009-2012 Aurélien APTEL <aurelien dot aptel at gmail dot com>
 5 | © 2009 Anselm R Garbe <garbeam at gmail dot com>
 6 | © 2012-2014 Roberto E. Vargas Caballero <k0ga at shike2 dot com>
 7 | © 2012-2014 Christoph Lohmann <20h at r-36 dot net>
 8 | © 2013 Eon S. Jeon <esjeon at hyunmu dot am>
 9 | © 2013 Alexander Sedov <alex0player at gmail dot com>
10 | © 2013 Mark Edgar <medgar123 at gmail dot com>
11 | © 2013 Eric Pruitt <eric.pruitt at gmail dot com>
12 | © 2013 Michael Forney <mforney at mforney dot org>
13 | © 2013-2014 Markus Teich <markus dot teich at stusta dot mhn dot de>
14 | © 2014 Laslo Hunhold <dev at frign dot de>
15 | 
16 | Common Lisp translation
17 | © 2015 Bart Botta <00003b at gmail dot com>
18 | 
19 | Permission is hereby granted, free of charge, to any person obtaining a
20 | copy of this software and associated documentation files (the "Software"),
21 | to deal in the Software without restriction, including without limitation
22 | the rights to use, copy, modify, merge, publish, distribute, sublicense,
23 | and/or sell copies of the Software, and to permit persons to whom the
24 | Software is furnished to do so, subject to the following conditions:
25 | 
26 | The above copyright notice and this permission notice shall be included in
27 | all copies or substantial portions of the Software.
28 | 
29 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
30 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
31 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
32 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
33 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
34 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
35 | DEALINGS IN THE SOFTWARE.
36 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
  1 | # 3bst
  2 | CL port of the terminal emulation part of st (http://st.suckless.org/)
  3 | 
  4 | Not very well tested, but seems to work well enough to run emacs for a bit.
  5 | 
  6 | general usage (probably missing some details):
  7 | 
  8 | ```lisp
  9 | 
 10 | (let ((term (make-instance '3bst:term :rows 10 :columns 40)))
 11 | 
 12 |   (3bst:handle-input (format nil "testing... ~c[31mRed~c[32mGreen~c[34mBlue~c[33m!"
 13 |                              (code-char 27) (code-char 27) (code-char 27) (code-char 27)) ;; (code-char 27) = esc
 14 |                      :term term)
 15 | 
 16 |   (loop with dirty = (3bst:dirty term);;bitvector of 'dirty' flag for each row
 17 |         for row below (3bst:rows term)
 18 |         do (format t "~,' 2d~a:" row (if (plusp (aref dirty row)) "*" " "))
 19 |            (loop for col below (3bst:columns term)
 20 |                  for glyph = (3bst:glyph-at (3bst::screen term) row col)
 21 |                  for char = (3bst:c glyph)
 22 |                  do (format t "~a" char))
 23 |            (format t "~%"))
 24 | 
 25 |   (loop for row below (3bst:rows term)
 26 |         do (format t "~,' 2d :" row)
 27 |            (loop for col below (3bst:columns term)
 28 |                  for glyph = (3bst:glyph-at (3bst::screen term) row col)
 29 |                  for fg = (3bst:color-rgb (3bst:fg glyph))
 30 |                  do (format t "~a" (destructuring-bind (r g b) fg
 31 |                                      (cond
 32 |                                        ((> r (max g b)) "r")
 33 |                                        ((> g (max r b)) "g")
 34 |                                        ((> b (max r g)) "b")
 35 |                                        ((< b (min r g)) "y")
 36 |                                        (t " ")))))
 37 |            (format t "~%")))
 38 | 
 39 | ;; ->
 40 | ;;
 41 | ;; 0*:testing... RedGreenBlue!                
 42 | ;; 1 :                                        
 43 | ;; 2 :                                        
 44 | ;; 3 :                                        
 45 | ;; 4 :                                        
 46 | ;; 5 :                                        
 47 | ;; 6 :                                        
 48 | ;; 7 :                                        
 49 | ;; 8 :                                        
 50 | ;; 9 :                                        
 51 | ;; 0 :           rrrgggggbbbby                
 52 | ;; 1 :                                        
 53 | ;; 2 :                                        
 54 | ;; 3 :                                        
 55 | ;; 4 :                                        
 56 | ;; 5 :                                        
 57 | ;; 6 :                                        
 58 | ;; 7 :                                        
 59 | ;; 8 :                                        
 60 | ;; 9 :                                        
 61 | 
 62 | ```
 63 | 
 64 | probably will want to use it with something like `SB-EXT:RUN-PROGRAM`, something like:
 65 | 
 66 | 
 67 | ```lisp
 68 | 
 69 | (let* ((term (make-instance '3bst:term :rows 12 :columns 51))
 70 |       ;; start ssh in a subprocess, with input and output as streams
 71 |       (proc (sb-ext:run-program "C:/Program Files (x86)/PuTTY/plink.exe"
 72 |                                 (list "192.168.0.1")
 73 |                                 :wait nil
 74 |                                 :output :stream
 75 |                                 :input :stream
 76 |                                 :external-format :utf-8))
 77 |        (stop nil)
 78 |        thread)
 79 |   ;; start a thread reading from the process and updating the term
 80 |   (setf thread
 81 |         (sb-thread:make-thread
 82 |          (lambda ()
 83 |            (loop for c = (read-char-no-hang (sb-ext:process-output proc)
 84 |                                             nil :eof)
 85 |                  until (eq c :eof)
 86 |                  when c
 87 |                    do (3bst:handle-input (string c) :term term)
 88 |                  until stop
 89 |                  unless c
 90 |                    do (sleep 0.01)))))
 91 |   ;; send some input to subprocess
 92 |   (format (sb-ext:process-input proc) "screen -xRR test emacs -nw~%")
 93 |   (finish-output (sb-ext:process-input proc))
 94 |   (sleep 1) ;; wait for it to respond
 95 |   (setf stop t) ;; exit the thread
 96 |   ;; print the output
 97 |   (loop with dirty = (3bst:dirty term)
 98 |         for row below (3bst:rows term)
 99 |         do (format t "~,' 2d~a:" row (if (plusp (aref dirty row)) "*" " "))
100 |            (loop for col below (3bst:columns term)
101 |                  for glyph = (3bst:glyph-at (3bst::screen term) row col)
102 |                  for char = (3bst:c glyph)
103 |                  do (format t "~a" char))
104 |            (format t "~%"))
105 |   ;; send some more input to exit screen and close shell
106 |   (format (sb-ext:process-input proc) (format nil "~cd~c" (code-char 1) (code-char 4))) ;; ^Ad^D
107 |   (finish-output (sb-ext:process-input proc))
108 |   (sb-thread:join-thread thread))
109 | 
110 | ;; ->
111 | 
112 | ;;  0*:Welcome to GNU Emacs, one component of the GNU/Li |
113 | ;;  1*:nux operating system.                             |
114 | ;;  2*:To follow a link, click Mouse-1 on it, or move to |
115 | ;;  3*: it and type RET.                                 |
116 | ;;  4*:To quit a partially entered command, type Control |
117 | ;;  5*:-g.                                               |
118 | ;;  6*:                                                  |
119 | ;;  7*:Important Help menu items:                        |
120 | ;;  8*:-UUU:%%--F1  *GNU Emacs*    Top L3     (Fundamenta|
121 | ;;  9*:                                                  |
122 | ;; 10*:-------------------------------------------------- 
123 | ;; 11*:                                                   
124 | 
125 | ```
126 | 
127 | 


--------------------------------------------------------------------------------
/bindings.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:3bst)
  2 | 
  3 | (defvar *key-alias*
  4 |   (alexandria:plist-hash-table
  5 |     '(:page-up :prior
  6 |       :page-down :next
  7 |       :numpad0 :kp_0
  8 |       :numpad1 :kp_1
  9 |       :numpad2 :kp_2
 10 |       :numpad3 :kp_3
 11 |       :numpad4 :kp_4
 12 |       :numpad5 :kp_5
 13 |       :numpad6 :kp_6
 14 |       :numpad7 :kp_7
 15 |       :numpad8 :kp_8
 16 |       :numpad9 :kp_9
 17 | )
 18 |     ))
 19 | 
 20 | (defvar *keys*
 21 |   ;;  keysym         mask            string      appkey appcursor crlf
 22 |   '((:KP_Home       :shift      ""       0   -1    0)
 23 |     (:KP_Home       :shift      ""     0   +1    0)
 24 |     (:KP_Home       :any     ""        0   -1    0)
 25 |     (:KP_Home       :any     "[1~"       0   +1    0)
 26 |     (:KP_Up         :any     "Ox"       +1    0    0)
 27 |     (:KP_Up         :any     ""        0   -1    0)
 28 |     (:KP_Up         :any     "OA"        0   +1    0)
 29 |     (:KP_Down       :any     "Or"       +1    0    0)
 30 |     (:KP_Down       :any     ""        0   -1    0)
 31 |     (:KP_Down       :any     "OB"        0   +1    0)
 32 |     (:KP_Left       :any     "Ot"       +1    0    0)
 33 |     (:KP_Left       :any     ""        0   -1    0)
 34 |     (:KP_Left       :any     "OD"        0   +1    0)
 35 |     (:KP_Right      :any     "Ov"       +1    0    0)
 36 |     (:KP_Right      :any     ""        0   -1    0)
 37 |     (:KP_Right      :any     "OC"        0   +1    0)
 38 |     (:KP_Prior      :shift      "[5;2~"     0    0    0)
 39 |     (:KP_Prior      :any     "[5~"       0    0    0)
 40 |     (:KP_Begin      :any     ""        0    0    0)
 41 |     (:KP_End        :control    ""       -1    0    0)
 42 |     (:KP_End        :control    ""    +1    0    0)
 43 |     (:KP_End        :shift      ""       -1    0    0)
 44 |     (:KP_End        :shift      ""    +1    0    0)
 45 |     (:KP_End        :any     "[4~"       0    0    0)
 46 |     (:KP_Next       :shift      "[6;2~"     0    0    0)
 47 |     (:KP_Next       :any     "[6~"       0    0    0)
 48 |     (:KP_Insert     :shift      "[2;2~"    +1    0    0)
 49 |     (:KP_Insert     :shift      ""      -1    0    0)
 50 |     (:KP_Insert     :control    ""       -1    0    0)
 51 |     (:KP_Insert     :control    "[2;5~"    +1    0    0)
 52 |     (:KP_Insert     :any     ""      -1    0    0)
 53 |     (:KP_Insert     :any     "[2~"      +1    0    0)
 54 |     (:KP_Delete     :control    ""       -1    0    0)
 55 |     (:KP_Delete     :control    "[3;5~"    +1    0    0)
 56 |     (:KP_Delete     :shift      ""      -1    0    0)
 57 |     (:KP_Delete     :shift      "[3;2~"    +1    0    0)
 58 |     (:KP_Delete     :any     ""       -1    0    0)
 59 |     (:KP_Delete     :any     "\\177"         +1    0    0)
 60 |     (:KP_Multiply   :any     "Oj"       +2    0    0)
 61 |     (:KP_Add        :any     "Ok"       +2    0    0)
 62 |     (:KP_Enter      :any     "OM"       +2    0    0)
 63 |     (:KP_Enter      :any     "\\r"           -1    0   -1)
 64 |     (:KP_Enter      :any     "\\r\\n"         -1    0   +1)
 65 |     (:KP_Subtract   :any     "Om"       +2    0    0)
 66 |     (:KP_Decimal    :any     "On"       +2    0    0)
 67 |     (:KP_Divide     :any     "Oo"       +2    0    0)
 68 |     (:KP_0          :any     "Op"       +2    0    0)
 69 |     (:KP_1          :any     "Oq"       +2    0    0)
 70 |     (:KP_2          :any     "Or"       +2    0    0)
 71 |     (:KP_3          :any     "Os"       +2    0    0)
 72 |     (:KP_4          :any     "Ot"       +2    0    0)
 73 |     (:KP_5          :any     "Ou"       +2    0    0)
 74 |     (:KP_6          :any     "Ov"       +2    0    0)
 75 |     (:KP_7          :any     "Ow"       +2    0    0)
 76 |     (:KP_8          :any     "Ox"       +2    0    0)
 77 |     (:KP_9          :any     "Oy"       +2    0    0)
 78 |     (:Up            :shift      ""     0    0    0)
 79 |     (:Up            :control    ""     0    0    0)
 80 |     (:Up            :mod1       ""     0    0    0)
 81 |     (:Up            :any     ""        0   -1    0)
 82 |     (:Up            :any     "OA"        0   +1    0)
 83 |     (:Down          :shift      ""     0    0    0)
 84 |     (:Down          :control    ""     0    0    0)
 85 |     (:Down          :mod1       ""     0    0    0)
 86 |     (:Down          :any     ""        0   -1    0)
 87 |     (:Down          :any     "OB"        0   +1    0)
 88 |     (:Left          :shift      ""     0    0    0)
 89 |     (:Left          :control    ""     0    0    0)
 90 |     (:Left          :mod1       ""     0    0    0)
 91 |     (:Left          :any     ""        0   -1    0)
 92 |     (:Left          :any     "OD"        0   +1    0)
 93 |     (:Right         :shift      ""     0    0    0)
 94 |     (:Right         :control    ""     0    0    0)
 95 |     (:Right         :mod1       ""     0    0    0)
 96 |     (:Right         :any     ""        0   -1    0)
 97 |     (:Right         :any     "OC"        0   +1    0)
 98 |     (:ISO_Left_Tab  :shift      ""        0    0    0)
 99 |     (:Return        :mod1       "\\r"        0    0   -1)
100 |     (:Return        :mod1       "\\r\\n"      0    0   +1)
101 |     (:Return        :any     "\\r"            0    0   -1)
102 |     (:Return        :any     "\\r\\n"          0    0   +1)
103 |     (:Insert        :shift      ""      -1    0    0)
104 |     (:Insert        :shift      "[2;2~"    +1    0    0)
105 |     (:Insert        :control    ""       -1    0    0)
106 |     (:Insert        :control    "[2;5~"    +1    0    0)
107 |     (:Insert        :any     ""      -1    0    0)
108 |     (:Insert        :any     "[2~"      +1    0    0)
109 |     (:Delete        :control    ""       -1    0    0)
110 |     (:Delete        :control    "[3;5~"    +1    0    0)
111 |     (:Delete        :shift      ""      -1    0    0)
112 |     (:Delete        :shift      "[3;2~"    +1    0    0)
113 |     (:Delete        :any     ""       -1    0    0)
114 |     (:Delete        :any     "\\177"         +1    0    0)
115 |     (:Home          :shift      ""       0   -1    0)
116 |     (:Home          :shift      ""     0   +1    0)
117 |     (:Home          :any     ""        0   -1    0)
118 |     (:Home          :any     "[1~"       0   +1    0)
119 |     (:End           :control    ""       -1    0    0)
120 |     (:End           :control    ""    +1    0    0)
121 |     (:End           :shift      ""       -1    0    0)
122 |     (:End           :shift      ""    +1    0    0)
123 |     (:End           :any     "[4~"       0    0    0)
124 |     (:Prior         :control    "[5;5~"     0    0    0)
125 |     (:Prior         :shift      "[5;2~"     0    0    0)
126 |     (:Prior         :any     "[5~"       0    0    0)
127 |     (:Next          :control    "[6;5~"     0    0    0)
128 |     (:Next          :shift      "[6;2~"     0    0    0)
129 |     (:Next          :any     "[6~"       0    0    0)
130 |     (:F1            nil      "OP"        0    0    0)
131 |     (:F1 #|| F13 ||#  :shift      ""     0    0    0)
132 |     (:F1 #|| F25 ||#  :control    ""     0    0    0)
133 |     (:F1 #|| F37 ||#  :mod4       ""     0    0    0)
134 |     (:F1 #|| F49 ||#  :mod1       ""     0    0    0)
135 |     (:F1 #|| F61 ||#  Mod3Mask       ""     0    0    0)
136 |     (:F2            nil      "OQ"        0    0    0)
137 |     (:F2 #|| F14 ||#  :shift      ""     0    0    0)
138 |     (:F2 #|| F26 ||#  :control    ""     0    0    0)
139 |     (:F2 #|| F38 ||#  :mod4       ""     0    0    0)
140 |     (:F2 #|| F50 ||#  :mod1       ""     0    0    0)
141 |     (:F2 #|| F62 ||#  Mod3Mask       ""     0    0    0)
142 |     (:F3            nil      "OR"        0    0    0)
143 |     (:F3 #|| F15 ||#  :shift      ""     0    0    0)
144 |     (:F3 #|| F27 ||#  :control    ""     0    0    0)
145 |     (:F3 #|| F39 ||#  :mod4       ""     0    0    0)
146 |     (:F3 #|| F51 ||#  :mod1       ""     0    0    0)
147 |     (:F3 #|| F63 ||#  Mod3Mask       ""     0    0    0)
148 |     (:F4            nil      "OS"        0    0    0)
149 |     (:F4 #|| F16 ||#  :shift      ""     0    0    0)
150 |     (:F4 #|| F28 ||#  :control    ""     0    0    0)
151 |     (:F4 #|| F40 ||#  :mod4       ""     0    0    0)
152 |     (:F4 #|| F52 ||#  :mod1       ""     0    0    0)
153 |     (:F5            nil      "[15~"      0    0    0)
154 |     (:F5 #|| F17 ||#  :shift      "[15;2~"    0    0    0)
155 |     (:F5 #|| F29 ||#  :control    "[15;5~"    0    0    0)
156 |     (:F5 #|| F41 ||#  :mod4       "[15;6~"    0    0    0)
157 |     (:F5 #|| F53 ||#  :mod1       "[15;3~"    0    0    0)
158 |     (:F6            nil      "[17~"      0    0    0)
159 |     (:F6 #|| F18 ||#  :shift      "[17;2~"    0    0    0)
160 |     (:F6 #|| F30 ||#  :control    "[17;5~"    0    0    0)
161 |     (:F6 #|| F42 ||#  :mod4       "[17;6~"    0    0    0)
162 |     (:F6 #|| F54 ||#  :mod1       "[17;3~"    0    0    0)
163 |     (:F7            nil      "[18~"      0    0    0)
164 |     (:F7 #|| F19 ||#  :shift      "[18;2~"    0    0    0)
165 |     (:F7 #|| F31 ||#  :control    "[18;5~"    0    0    0)
166 |     (:F7 #|| F43 ||#  :mod4       "[18;6~"    0    0    0)
167 |     (:F7 #|| F55 ||#  :mod1       "[18;3~"    0    0    0)
168 |     (:F8            nil      "[19~"      0    0    0)
169 |     (:F8 #|| F20 ||#  :shift      "[19;2~"    0    0    0)
170 |     (:F8 #|| F32 ||#  :control    "[19;5~"    0    0    0)
171 |     (:F8 #|| F44 ||#  :mod4       "[19;6~"    0    0    0)
172 |     (:F8 #|| F56 ||#  :mod1       "[19;3~"    0    0    0)
173 |     (:F9            nil      "[20~"      0    0    0)
174 |     (:F9 #|| F21 ||#  :shift      "[20;2~"    0    0    0)
175 |     (:F9 #|| F33 ||#  :control    "[20;5~"    0    0    0)
176 |     (:F9 #|| F45 ||#  :mod4       "[20;6~"    0    0    0)
177 |     (:F9 #|| F57 ||#  :mod1       "[20;3~"    0    0    0)
178 |     (:F10           nil      "[21~"      0    0    0)
179 |     (:F10 #|| F22 ||# :shift      "[21;2~"    0    0    0)
180 |     (:F10 #|| F34 ||# :control    "[21;5~"    0    0    0)
181 |     (:F10 #|| F46 ||# :mod4       "[21;6~"    0    0    0)
182 |     (:F10 #|| F58 ||# :mod1       "[21;3~"    0    0    0)
183 |     (:F11           nil      "[23~"      0    0    0)
184 |     (:F11 #|| F23 ||# :shift      "[23;2~"    0    0    0)
185 |     (:F11 #|| F35 ||# :control    "[23;5~"    0    0    0)
186 |     (:F11 #|| F47 ||# :mod4       "[23;6~"    0    0    0)
187 |     (:F11 #|| F59 ||# :mod1       "[23;3~"    0    0    0)
188 |     (:F12           nil      "[24~"      0    0    0)
189 |     (:F12 #|| F24 ||# :shift      "[24;2~"    0    0    0)
190 |     (:F12 #|| F36 ||# :control    "[24;5~"    0    0    0)
191 |     (:F12 #|| F48 ||# :mod4       "[24;6~"    0    0    0)
192 |     (:F12 #|| F60 ||# :mod1       "[24;3~"    0    0    0)
193 |     (:F13           nil      ""     0    0    0)
194 |     (:F14           nil      ""     0    0    0)
195 |     (:F15           nil      ""     0    0    0)
196 |     (:F16           nil      ""     0    0    0)
197 |     (:F17           nil      "[15;2~"    0    0    0)
198 |     (:F18           nil      "[17;2~"    0    0    0)
199 |     (:F19           nil      "[18;2~"    0    0    0)
200 |     (:F20           nil      "[19;2~"    0    0    0)
201 |     (:F21           nil      "[20;2~"    0    0    0)
202 |     (:F22           nil      "[21;2~"    0    0    0)
203 |     (:F23           nil      "[23;2~"    0    0    0)
204 |     (:F24           nil      "[24;2~"    0    0    0)
205 |     (:F25           nil      ""     0    0    0)
206 |     (:F26           nil      ""     0    0    0)
207 |     (:F27           nil      ""     0    0    0)
208 |     (:F28           nil      ""     0    0    0)
209 |     (:F29           nil      "[15;5~"    0    0    0)
210 |     (:F30           nil      "[17;5~"    0    0    0)
211 |     (:F31           nil      "[18;5~"    0    0    0)
212 |     (:F32           nil      "[19;5~"    0    0    0)
213 |     (:F33           nil      "[20;5~"    0    0    0)
214 |     (:F34           nil      "[21;5~"    0    0    0)
215 |     (:F35           nil      "[23;5~"    0    0    0)
216 |     ))
217 | 
218 | 
219 | (defun kmap (k state &key (term *term*))
220 |   (loop for (key mask string appkey appcursor crlf) in *keys*
221 |         unless (or (not (or (eq key k)
222 |                             (eq key (gethash k *key-alias*))))
223 |                    (not (or (eq mask state)
224 |                             (eq mask :any)
225 |                             (member mask state)))
226 |                    (if (logtest (mode term) +mode-appkeypad+)
227 |                        (minusp appkey)
228 |                        (plusp appkey))
229 |                    (and (numlock term)
230 |                         (eql appkey 2))
231 |                    (if (logtest (mode term) +mode-appcursor+)
232 |                        (minusp appcursor)
233 |                        (plusp appcursor))
234 |                    (if (logtest (mode term) +mode-crlf+)
235 |                        (minusp crlf)
236 |                        (plusp crlf)))
237 |           do (return-from kmap string))
238 |   nil)
239 | 
240 | #++(defun default-bindings (&optional bindings)
241 |   ;; nil=copy *bindings*, t = new, hash = copy hash
242 |   (let ((h (make-hash-table :test 'equal)))
243 |     (when (eq bindings nil)
244 |       (setf bindings *bindings*))
245 |     (unless (eq bindings t)
246 |       (maphash (lambda (k v) (setf (gethash k h) v)) bindings))
247 |     
248 |     
249 | )
250 |   
251 | )
252 | 


--------------------------------------------------------------------------------
/package.lisp:
--------------------------------------------------------------------------------
 1 | (defpackage #:3bst
 2 |   (:use :cl)
 3 |   (:export
 4 |    #:term
 5 |    #:glyph-at
 6 |    #:c
 7 |    #:glyph-attributes
 8 |    #:dirty
 9 |    #:rows
10 |    #:columns
11 |    #:*term*
12 |    #:*title*
13 |    #:handle-input
14 |    #:fg
15 |    #:bg
16 |    #:color-rgb)
17 |   )
18 | 


--------------------------------------------------------------------------------
/st.lisp:
--------------------------------------------------------------------------------
   1 | ;;; See LICENSE for licence details.
   2 | (in-package #:3bst)
   3 | 
   4 | ;;; todo: better interface for sending output to child process
   5 | ;; possibly users could subclass TERM and define a method to handle output?
   6 | ;; for now just bind this to a function like
   7 | ;; (lambda (term string) ...)
   8 | (defparameter *write-to-child-hook* nil)
   9 | 
  10 | ;; possibly these should be propertie of term?
  11 | (defvar *default-foreground* 7)
  12 | (defvar *default-background* 0)
  13 | (defvar *tab-spaces* 8)
  14 | (defvar *vt-iden* "[?6c") ;; "1;2"=vt100w/advanced video option, "6"=vt102
  15 | (defvar *redraw-timeout* (/ 80 1000.0)) ;; 80 ms
  16 | 
  17 | (defvar *bindings* (make-hash-table :test 'equalp))
  18 | 
  19 | ;;;  Arbitrary sizes
  20 | #++(defconstant +UTF-INVALID+ #xFFFD)
  21 | #++(defconstant +UTF-SIZ+ 4)
  22 | #++(defconstant +ESC-BUF-SIZ+ (128*+UTF-SIZ+))
  23 | (defconstant +esc-max-args+ 16)
  24 | #++(defconstant +STR-BUF-SIZ+ +ESC-BUF-SIZ+)
  25 | #++(defconstant +STR-ARG-SIZ+ +ESC-ARG-SIZ+)
  26 | (defconstant +csi-buf-max-size+ 128)
  27 | (defconstant +str-buf-max-size+ 128)
  28 | #++(defconstant +DRAW-BUF-SIZ+ 20*1024)
  29 | 
  30 | (defun controlc0-p (c)
  31 |   (or (= c 177) (<= 0 c #x1f)))
  32 | 
  33 | (defun controlc1-p (c)
  34 |   (<= #x80 c #x9f))
  35 | 
  36 | (defun control-p (c)
  37 |   (or (controlc1-p c) (controlc0-p c)))
  38 | 
  39 | (defmacro ensure-value (x default)
  40 |   ;; fixme: get rid of multiple evaluation
  41 |   `(unless (and ,x (not (zero ,x)))
  42 |      (seft ,x ,default)))
  43 | 
  44 | (defmacro ensure-aref (array index default)
  45 |   "adjust array to hold at least INDEX elements, and set element INDEX
  46 | to DEFAULt if not already set"
  47 |   (let ((a (gensym))
  48 |         (i (gensym)))
  49 |     `(let ((,a ,array)
  50 |            (,i ,index))
  51 |        (when (< (fill-pointer ,a) (1+ ,i))
  52 |          (unless (adjustable-array-p ,a)
  53 |            (assert (< ,i (array-total-size ,a))))
  54 |          (adjust-array ,a (max (1+ ,i) (array-total-size ,a))
  55 |                        :fill-pointer (1+ ,i)
  56 |                        :initial-element nil))
  57 |        (unless (and (aref ,a ,i) (plusp (aref ,a ,i)))
  58 |          (setf (aref ,a ,i) ,default)))))
  59 | 
  60 | #++(let ((a (make-array 6 :fill-pointer 0)))
  61 |      (ensure-aref a 0 2)
  62 |      (ensure-aref a 1 3)
  63 |      a)
  64 | (defun limit (x a b)
  65 |   (min b (max a x)))
  66 | 
  67 | (defmacro limitf (x a b)
  68 |   ;; fixme: get rid of repeated evaluation of X
  69 |   `(setf ,x (limit ,x ,a ,b)))
  70 | 
  71 | (defun attribute/= (a b)
  72 |   ;; assuming mode is an int with flag bits for now
  73 |   (or (/= (mode a) (mode b))
  74 |       (/= (fg a) (fg b))
  75 |       (/= (bg a) (bg b))))
  76 | 
  77 | (defvar *term*)
  78 | (defun attribute-set-p (flag &key (term *term*)) ;; IS_SET
  79 |   ;; fixme: might be nicer to have :keywords instead of +constants+ for flags?
  80 |   (logtest flag (mode term)))
  81 | 
  82 | (defmacro modbit (x set mask)
  83 |   ;; fixme: avoid multiple evaluation
  84 |   `(setf ,x
  85 |          ,(case set
  86 |             ((nil)
  87 |              `(logandc2 ,x ,mask))
  88 |             ((t)
  89 |              `(logior ,x ,mask))
  90 |             (t
  91 |              `(if ,set
  92 |                   (logior ,x ,mask)
  93 |                   (logandc2 ,x ,mask))))))
  94 | 
  95 | (defun truecolor (r g b)
  96 |   (logior (ash 1 24)
  97 |           (ash r 16)
  98 |           (ash g 8)
  99 |           b))
 100 | 
 101 | (defun truecolorp (x)
 102 |   (logbitp 24 x))
 103 | 
 104 | (defun truecolor-red (x)
 105 |   (ldb (byte 8 16) x))
 106 | (defun truecolor-green (x)
 107 |   (ldb (byte 8 8) x))
 108 | (defun truecolor-blue (x)
 109 |   (ldb (byte 8 0) x))
 110 | 
 111 | (defun color-rgb (color)
 112 |   ;; fixme: should this return list or (typed?) vector?
 113 |   (labels ((c (r g b)
 114 |              (list (/ r 255.0) (/ g 255.0) (/ b 255.0)))
 115 |            (c6 (x)
 116 |              (let ((b (mod x 6))
 117 |                    (g (mod (floor x 6) 6))
 118 |                    (r (mod (floor x 36) 6)))
 119 |                (list (/ r 5.0) (/ g 5.0) (/ b 5.0))))
 120 |            (g (x)
 121 |              (c (* x 16) (* x 16) (* x 16))))
 122 |     (if (truecolorp color)
 123 |         (c (truecolor-red color)
 124 |            (truecolor-green color)
 125 |            (truecolor-blue color))
 126 |         (case color
 127 |           (0 (c 0 0 0))
 128 |           (1 (c 205 0 0))
 129 |           (2 (c 0 205 0))
 130 |           (3 (c 205 205 0))
 131 |           (4 (c 0 0 238))
 132 |           (5 (c 205 0 205))
 133 |           (6 (c 0 205 205))
 134 |           (7 (c 229 229 229))
 135 |           (8 (c 127 127 127))
 136 |           (9 (c 255 0 0))
 137 |           (10 (c 0 255 0))
 138 |           (11 (c 255 255 0))
 139 |           (12 (c 92 92 255))
 140 |           (13 (c 255 0 255))
 141 |           (14 (c 0 255 255))
 142 |           (15 (c 255 255 255))
 143 |           (t (let ((c (- color 16)))
 144 |                (if (< c 216)
 145 |                    (c6 c)
 146 |                    (g (- c 216)))))))))
 147 | 
 148 | ;; not sure if these should be bit masks or bit indices?
 149 | ;; (or keywords?)
 150 | (defconstant +ATTR-NULL+  0)
 151 | (defconstant +ATTR-BOLD+  (ash 1 0))
 152 | (defconstant +ATTR-FAINT+  (ash 1 1))
 153 | (defconstant +ATTR-ITALIC+  (ash 1 2))
 154 | (defconstant +ATTR-UNDERLINE+  (ash 1 3))
 155 | (defconstant +ATTR-BLINK+  (ash 1 4))
 156 | (defconstant +ATTR-REVERSE+  (ash 1 5))
 157 | (defconstant +ATTR-INVISIBLE+  (ash 1 6))
 158 | (defconstant +ATTR-STRUCK+  (ash 1 7))
 159 | (defconstant +ATTR-WRAP+  (ash 1 8))
 160 | (defconstant +ATTR-WIDE+  (ash 1 9))
 161 | (defconstant +ATTR-WDUMMY+  (ash 1 10))
 162 | 
 163 | (defconstant +cursor-default+ 0)
 164 | (defconstant +cursor-wrap-next+ 1)
 165 | (defconstant +cursor-origin+ 2)
 166 | 
 167 | (defconstant +MODE-WRAP+ (ash 1 0))
 168 | (defconstant +MODE-INSERT+ (ash 1 1))
 169 | (defconstant +MODE-APPKEYPAD+ (ash 1 2))
 170 | (defconstant +MODE-ALTSCREEN+ (ash 1 3))
 171 | (defconstant +MODE-CRLF+ (ash 1 4))
 172 | (defconstant +MODE-MOUSEBTN+ (ash 1 5))
 173 | (defconstant +MODE-MOUSEMOTION+ (ash 1 6))
 174 | (defconstant +MODE-REVERSE+ (ash 1 7))
 175 | (defconstant +MODE-KBDLOCK+ (ash 1 8))
 176 | (defconstant +MODE-HIDE+ (ash 1 9))
 177 | (defconstant +MODE-ECHO+ (ash 1 10))
 178 | (defconstant +MODE-APPCURSOR+ (ash 1 11))
 179 | (defconstant +MODE-MOUSESGR+ (ash 1 12))
 180 | (defconstant +MODE-8BIT+ (ash 1 13))
 181 | (defconstant +MODE-BLINK+ (ash 1 14))
 182 | (defconstant +MODE-FBLINK+ (ash 1 15))
 183 | (defconstant +MODE-FOCUS+ (ash 1 16))
 184 | (defconstant +MODE-MOUSEX10+ (ash 1 17))
 185 | (defconstant +MODE-MOUSEMANY+ (ash 1 18))
 186 | (defconstant +MODE-BRCKTPASTE+ (ash 1 19))
 187 | (defconstant +MODE-PRINT+ (ash 1 20))
 188 | (defconstant +MODE-MOUSE+ (logior +MODE-MOUSEBTN+
 189 |                                   +MODE-MOUSEMOTION+
 190 |                                   +MODE-MOUSEX10+
 191 |                                   +MODE-MOUSEMANY+))
 192 | 
 193 | (defconstant +ESC-START+ 1)
 194 | (defconstant +ESC-CSI+ 2)
 195 | (defconstant +ESC-STR+ 4)  ; DCS, OSC, PM, APC
 196 | (defconstant +ESC-ALTCHARSET+ 8)
 197 | (defconstant +ESC-STR-END+ 16) ; a final string was encountered
 198 | (defconstant +ESC-TEST+ 32) ; Enter in test mode
 199 | 
 200 | 
 201 | 
 202 | (defconstant +WIN-VISIBLE+ 1)
 203 | (defconstant +WIN-REDRAW+ 2)
 204 | (defconstant +WIN-FOCUSED+ 4)
 205 | 
 206 | (defconstant +SEL-REGULAR+ 1)
 207 | (defconstant +SEL-RECTANGULAR+ 2)
 208 | 
 209 | (defconstant +SNAP-WORD+ 1)
 210 | (defconstant +SNAP-LINE+ 2)
 211 | 
 212 | ;; not sure if we want AoS or SoA for term data yet?
 213 | (defclass glyph ()
 214 |   ;; C stores a CL character instead of utf8 encoded string
 215 |   ((c :accessor c :initform #\space)
 216 |    (mode :accessor mode :initform +attr-null+)
 217 |    (fg :accessor fg :initform *default-foreground*)
 218 |    (bg :accessor bg :initform *default-background*)))
 219 | 
 220 | (defmethod glyph-attributes ((g glyph))
 221 |   (loop for mask in (list +ATTR-NULL+ +ATTR-BOLD+ +ATTR-FAINT+ +ATTR-ITALIC+
 222 |                           +ATTR-UNDERLINE+ +ATTR-BLINK+ +ATTR-REVERSE+
 223 |                           +ATTR-INVISIBLE+ +ATTR-STRUCK+ +ATTR-WRAP+
 224 |                           +ATTR-WIDE+ +ATTR-WDUMMY+)
 225 |      for key in '(:NULL :BOLD :FAINT :ITALIC :UNDERLINE :BLINK
 226 |                   :REVERSE :INVISIBLE :STRUCK :WRAP :WIDE :WDUMMY)
 227 |      when (logtest mask (mode g))
 228 |      collect key))
 229 | 
 230 | (deftype line () '(vector glyph *))
 231 | 
 232 | (defun move-glyphs (line &key (start1 0) (start2 0)
 233 |                            (end1 (length line))
 234 |                            (end2 (length line)))
 235 |   ;; fixme: better representation of LINE and/or GLYPH for easier copying?
 236 |   ;; just using REPLACE on LINE ends up with same GLYPH object in
 237 |   ;; multiple places
 238 |   ;; -- maybe just use REPLACE and fill the gap with new GLYPHs?
 239 |   (if (<= start1 start2)
 240 |       (loop for i from start1 below end1
 241 |          for j from start2 below end2
 242 |          for d = (aref line i)
 243 |          for s = (aref line j)
 244 |          do (setf (c d) (c s)
 245 |                   (mode d) (mode s)
 246 |                   (fg d) (fg s)
 247 |                   (bg d) (bg s)))
 248 |       (loop for i from (1- end1) downto start1
 249 |          for j from (1- end2) downto start2
 250 |          for d = (aref line i)
 251 |          for s = (aref line j)
 252 |          do (setf (c d) (c s)
 253 |                   (mode d) (mode s)
 254 |                   (fg d) (fg s)
 255 |                   (bg d) (bg s)))))
 256 | 
 257 | (defclass tcursor ()
 258 |   ((attributes :accessor attributes :initform (make-instance 'glyph))
 259 |    (x :accessor x :initform 0)
 260 |    (y :accessor y :initform 0)
 261 |    (state :accessor state :initform 0)))
 262 | 
 263 | (defmethod (setf x) :before (new (c tcursor))
 264 |   (assert (numberp new)))
 265 | (defmethod (setf y) :before (new (c tcursor))
 266 |   (assert (numberp new)))
 267 | 
 268 | (defun copy-glyph (g &key (to (make-instance 'glyph)))
 269 |   (setf (c to) (c g)
 270 |         (mode to) (mode g)
 271 |         (fg to) (fg g)
 272 |         (bg to) (bg g))
 273 |   to)
 274 | (defun copy-cursor (c &key (to (make-instance 'tcursor)))
 275 |   (copy-glyph (attributes c) :to (attributes to))
 276 |   (setf (x to) (x c)
 277 |         (y to) (y c)
 278 |         (state to) (state c))
 279 |   to)
 280 | 
 281 | ;; CSI Escape sequence structs
 282 | ;; ESC '[' [[ [<priv>] <arg> [;]] <mode>]
 283 | (defclass csi-escape ()
 284 |   ;; fixme: decide initial sizes of these arrays based on usage
 285 |   ((buffer :accessor buffer :initform (make-array 8
 286 |                                                   :adjustable t
 287 |                                                   :fill-pointer 0
 288 |                                                   :element-type 'character))
 289 |    (priv :accessor priv :initform nil)
 290 |    (arguments :accessor arguments :initform (make-array 1
 291 |                                                         :adjustable t
 292 |                                                         :fill-pointer 0
 293 |                                                         :element-type 'integer))
 294 |    (mode :accessor mode :initform 0)))
 295 | 
 296 | 
 297 | ;;; STR Escape sequence structs
 298 | ;;; ESC type [[ [<priv>] <arg> [;]] <mode>] ESC '\'
 299 | (defclass str-escape ()
 300 |   ((str-type :accessor str-type :initform 0 :initarg :c)
 301 |    (buffer :accessor buffer :initform (make-array 8
 302 |                                                   :adjustable t
 303 |                                                   :fill-pointer 0
 304 |                                                   :element-type 'character))
 305 |    (priv :accessor priv :initform nil)
 306 |    (arguments :accessor arguments
 307 |               :initform (make-array 2
 308 |                                     :adjustable t
 309 |                                     :fill-pointer 0))))
 310 | 
 311 | 
 312 | ;;; Internal representation of the screen
 313 | (defun make-screen-array (rows columns)
 314 |   ;; array of arrays instead of 2d array to match original
 315 |   ;; which swaps lines for scrolling, and to allow sequence ops
 316 |   ;; within a line
 317 |   (make-array rows
 318 |               :element-type '(vector glyph *)
 319 |               :initial-contents
 320 |               (loop repeat rows
 321 |                  collect (coerce
 322 |                           (loop repeat columns
 323 |                              collect (make-instance 'glyph))
 324 |                           '(vector glyph)))))
 325 | 
 326 | (declaim (inline glyph-at))
 327 | (defun glyph-at (screen y x)
 328 |   (aref (aref screen y) x))
 329 | (defun map-screen (screen function)
 330 |   (loop for line across screen
 331 |      for y from 0
 332 |      do (loop for glyph across line
 333 |            for x from 0
 334 |            do (funcall function glyph y x))))
 335 | 
 336 | (defclass term ()
 337 |   ((rows :reader rows :initarg :rows :initform 25)
 338 |    (columns :reader columns :initarg :columns :initform 80)
 339 |    ;; vector of vectors of glyphs?
 340 |    (screen :reader screen)
 341 |    (alternate-screen :reader alternate-screen)
 342 |    ;; bit/boolean array with element fpor each row?
 343 |    (dirty :reader dirty)
 344 |    (cursor :accessor cursor :initform (make-instance 'tcursor))
 345 |    ;; top/bottom scroll limits
 346 |    (top :accessor top :initform 0)
 347 |    (bottom :accessor bottom :initform 0)
 348 |    ;; terminal mode flags
 349 |    (mode :accessor mode :initform +mode-crlf+ :initarg :mode)
 350 |    ;; escape state flags
 351 |    (escape :accessor escape :initform 0)
 352 |    ;; charset table translation
 353 |    ;; fixme: initial value?
 354 |    (translation-table :reader translation-table
 355 |                       :initform (make-array 4 :initial-element :cs-usa))
 356 |    (charset :accessor charset :initform 0)
 357 |    ;; selected charset for sequence
 358 |    (icharset :accessor icharset :initform 0)
 359 |    (numlock :accessor numlock :initform t)
 360 |    ;; tab stops?
 361 |    (tabs :reader tabs)
 362 |    ;; if processing input as raw bytes, store partial utf-8 characters
 363 |    (partial-raw-input :accessor partial-raw-input :initform nil)
 364 |    ;;
 365 |    (saved-cursors :reader saved-cursors
 366 |                   :initform (make-array 2 :initial-contents
 367 |                                         (loop repeat 2
 368 |                                            collect (make-instance 'tcursor))))
 369 |    (allow-alt-screen :accessor allow-alt-screen :initform t)
 370 |    (csi-escape :accessor csi-escape :initform (make-instance 'csi-escape))
 371 |    (str-escape :accessor str-escape :initform (make-instance 'str-escape))
 372 |    (user-object :accessor user-object :initform nil)
 373 |    (set-title :accessor on-set-title :initform nil)))
 374 | 
 375 | (defmethod initialize-instance :after ((term term) &key)
 376 |   (setf (slot-value term 'screen)
 377 |         (make-screen-array (rows term) (columns term)))
 378 |   (setf (slot-value term 'alternate-screen)
 379 |         (make-screen-array (rows term) (columns term)))
 380 |   (setf (slot-value term 'dirty)
 381 |         (make-array (rows term) :element-type 'bit))
 382 |   (setf (slot-value term 'tabs)
 383 |         (make-array (columns term) :element-type 'bit))
 384 |   (setf (bottom term) (1- (rows term))))
 385 | 
 386 | ;;; Globals
 387 | (defparameter *term* (make-instance 'term :rows 25 :columns 80))
 388 | #++(defparameter *csi-escape* (make-instance 'csi-escape))
 389 | #++(defparameter *str-escape* (make-instance 'str-escape))
 390 | ;; static Selection sel;
 391 | (defparameter *title* "")
 392 | ;;
 393 | ;;static uchar utfbyte[+UTF-SIZ+ + 1] = {0x80,    0, 0xC0, 0xE0, 0xF0};
 394 | ;;static uchar utfmask[+UTF-SIZ+ + 1] = {0xC0, 0x80, 0xE0, 0xF0, 0xF8};
 395 | ;;static long utfmin[+UTF-SIZ+ + 1] = {       0,    0,  0x80,  0x800,  0x10000};
 396 | ;;static long utfmax[+UTF-SIZ+ + 1] = {0x10FFFF, 0x7F, 0x7FF, 0xFFFF, 0x10FFFF};
 397 | 
 398 | (defun term-line-length (y &key (term *term*))
 399 |   (let* ((screen (screen term))
 400 |          (i (array-dimension screen 1)))
 401 |     (when (logtest +attr-wrap+ (mode (glyph-at screen y (1- i))))
 402 |       (return-from term-line-length i))
 403 |     (loop while (and (plusp i)
 404 |                      (eql #\space (c (glyph-at screen y (1- i)))))
 405 |        do (decf i))
 406 |     i))
 407 | 
 408 | ;;;; todo: mouse/selection stuff
 409 | 
 410 | ;;;; todo: utils for running a shell with env etc? handle child closed, etc
 411 | ;; (probably mostly let uiop deal with that)
 412 | 
 413 | (defun handle-input-raw (octets &key (term *term*))
 414 |   "process OCTETS as (possibly incomplete) UTF8 encoded input from
 415 | child process"
 416 |   (declare (ignore octets term))
 417 |   (error "not done yet, use character input..."))
 418 | 
 419 | (defun handle-input (characters &key (term *term*))
 420 |   ""
 421 |   (let ((*term* term))
 422 |     (map 'nil #'tputc characters)))
 423 | 
 424 | 
 425 | (defun tty-write (characters &key (term *term*))
 426 |   ;; (format t "tty-write ~s~%" characters)
 427 | 
 428 |   (when *write-to-child-hook*
 429 |     (funcall *write-to-child-hook* term characters)))
 430 | 
 431 | (defun tty-send (characters &key (term *term*))
 432 |   (tty-write characters :term term)
 433 |   (when (attribute-set-p +mode-echo+ :term term)
 434 |     (techo characters :term term)))
 435 | 
 436 | 
 437 | #++
 438 | (defun tty-resize ()
 439 |   ;; todo: implement some way of passing this to caller in case it has a TTY
 440 |   ;; and wants to do ioctl(..., TIOCSWINSZ, ...) or similar
 441 |   )
 442 | 
 443 | (defun tattrset (attr &key (term *term*))
 444 |   (loop for line across (screen term)
 445 |      thereis (loop for glyph across line
 446 |                 thereis (logtest attr (mode glyph)))))
 447 | 
 448 | (defun tsetdirt (top bottom &key (term *term*))
 449 |   (loop for i from (limit top 0 (1- (rows term)))
 450 |      below (limit bottom 0 (1- (rows term)))
 451 |      do (setf (aref (dirty term) i) 1)))
 452 | 
 453 | (defun tsetdirtattr (attr &key (term *term*))
 454 |   (loop for line across (screen term)
 455 |      for i from 0
 456 |      do (loop for glyph across line
 457 |            when (logtest attr (mode glyph))
 458 |            do (tsetdirt i i :term term)
 459 |            and return nil)))
 460 | 
 461 | (defun tfulldirt (&key (term *term*))
 462 |   (tsetdirt 0 (1- (rows term)) :term term))
 463 | 
 464 | (defun tcursor (mode &key (term *term*))
 465 |   (let ((index (if (attribute-set-p +mode-altscreen+ :term term) 1 0)))
 466 |     (if (eql mode :cursor-save)
 467 |         (setf (aref (saved-cursors term) index)
 468 |               (copy-cursor (cursor term)))
 469 |         (progn
 470 |           (let ((c (aref (saved-cursors term) index)))
 471 |             (copy-cursor c :to (cursor term))
 472 |             (tmoveto (x c) (y c)))))))
 473 | 
 474 | (defun treset (&key (term *term*))
 475 |   ;; fixme: this should probably mostly be in reinitialize-instance or something
 476 |   ;; fixme: possibly should pass fg,bg,tab spaces, etc as keyword args? (depending on if user code calls this or not)
 477 |   (let ((c (cursor term)))
 478 |     (setf (attributes c) (make-instance 'glyph)
 479 |           (x c) 0
 480 |           (y c) 0
 481 |           (state c) 0))
 482 |   (fill (tabs term) 0)
 483 |   (loop for i from *tab-spaces* below (columns term) by *tab-spaces*
 484 |      do (setf (aref (tabs term) i) 1))
 485 |   (setf (top term) 0
 486 |         (bottom term) (1- (rows term))
 487 |         (mode term) +mode-wrap+
 488 |         (charset term) 0)
 489 |   (fill (translation-table term) :cs-usa)
 490 |   (loop repeat 2
 491 |      do (tmoveto 0 0 :term term)
 492 |        (tcursor :cursor-save :term term)
 493 |        (tclearregion 0 0 (1- (columns term)) (1- (rows term)) :term term)
 494 |        (tswapscreen :term term)))
 495 | 
 496 | (defun tswapscreen (&key (term *term*))
 497 |   (rotatef (slot-value term 'screen) (slot-value term 'alternate-screen))
 498 |   (setf (mode term) (logxor (mode term) +mode-altscreen+))
 499 |   (tfulldirt :term term))
 500 | 
 501 | (defun tscrolldown (orig n &key (term *term*))
 502 |   (let* ((bottom (bottom term)) (n (limit n 0 (1+ (- bottom orig))))
 503 |          (screen (screen term)))
 504 |     (tsetdirt orig bottom :term term)
 505 |     (tclearregion 0 (1+ (- bottom n)) (1- (columns term)) bottom :term term)
 506 |     (loop for i from bottom downto (+ orig n)
 507 |        do (rotatef (aref screen i)
 508 |                    (aref screen (- i n))))
 509 |     #++(selscroll orig n) ;; todo
 510 |     ))
 511 | 
 512 | 
 513 | (defun tscrollup (orig n &key (term *term*))
 514 |   (let* ((bottom (bottom term)) (n (limit n 0 (1+ (- bottom orig))))
 515 |          (screen (screen term)))
 516 |     (tclearregion 0 orig (1- (columns term)) (1- (+ orig n)) :term term)
 517 |     (tsetdirt (+ orig n) bottom :term term)
 518 |     (loop for i from orig to (- bottom n)
 519 |        do (rotatef (aref screen i)
 520 |                    (aref screen (+ i n))))
 521 |     #++(selscroll orig (- n)) ;; todo
 522 |     ))
 523 | 
 524 | #++
 525 | (defun selscroll (orig n)
 526 |   ;; todo: selection stuff
 527 |   )
 528 | 
 529 | (defun tnewline (first-column &key (term *term*))
 530 |   (let ((y (y (cursor term))))
 531 |     (if (= y (bottom term))
 532 |         (tscrollup (top term) 1 :term term)
 533 |         (incf y))
 534 |     (tmoveto (if first-column 0 (x (cursor term)))
 535 |              y :term term)))
 536 | 
 537 | 
 538 | 
 539 | (defun csiparse (csi)
 540 |   (let ((p 0))
 541 |     (flet ((*p ()
 542 |              (aref (buffer csi) p)))
 543 |       (setf (fill-pointer (arguments csi)) 0)
 544 |       (setf (priv csi) nil)
 545 |       (when (char= (*p) #\?)
 546 |         (setf (priv csi) 1)
 547 |         (incf p))
 548 |       (loop while (< p (fill-pointer (buffer csi)))
 549 |          do (multiple-value-bind (v np)
 550 |                 (parse-integer (buffer csi) :start p :radix 10
 551 |                                :junk-allowed t)
 552 |               (vector-push-extend (or v 0)
 553 |                                   (arguments csi))
 554 |               (setf p np)
 555 |               (when (or (char/= (*p) #\;)
 556 |                         ;; possibly should ERROR with restarts
 557 |                         ;; instead of just giving up?
 558 |                         (> (length (arguments csi))
 559 |                            +esc-max-args+))
 560 |                 (loop-finish))
 561 |               (incf p)))
 562 |       (setf (mode csi) (*p)))))
 563 | 
 564 | 
 565 | ;;; for absolute user moves, when decom is set
 566 | (defun tmoveato (x y &key (term *term*))
 567 |   #++(format *debug-io* "moveato ~s,~s -> ~s ~s~%"
 568 |              (x (cursor term)) (y (cursor term))
 569 |              x y)
 570 |   (tmoveto x (+ y (if (logtest (state (cursor term)) +cursor-origin+)
 571 |                       (top term)
 572 |                       0))
 573 |            :term term))
 574 | 
 575 | (defun tmoveto (x y &key (term *term*))
 576 |   #++(format *debug-io* "moveto ~s,~s -> ~s ~s~%"
 577 |              (x (cursor term)) (y (cursor term))
 578 |              x y)
 579 |   (let ((miny 0)
 580 |         (maxy (1- (rows term)))
 581 |         (c (cursor term)))
 582 |     (when (logtest +cursor-origin+ (state c))
 583 |       (setf miny (top term)
 584 |             maxy (bottom term)))
 585 |     (setf x (limit x 0 (1- (columns term))))
 586 |     (setf y (limit y miny maxy))
 587 |     (setf (state c) (logandc2 (state c) +cursor-wrap-next+)
 588 |           (x c) x
 589 |           (y c) y)))
 590 | 
 591 | (defparameter *vt100-0*
 592 |   ;; The table is proudly stolen from rxvt.
 593 |   (map 'vector 'code-char
 594 |        ;; fixme: figure out encoding problems that prevented just
 595 |        ;; putting in characters...
 596 |        #(8593 8595 8594 8592 9608 9626 9731
 597 |          0 0 0 0 0 0 0 0
 598 |          0 0 0 0 0 0 0 0
 599 |          0 0 0 0 0 0 0 32
 600 |          9670 9618 9225 9228 9229 9226 176 177
 601 |          9252 9227 9496 9488 9484 9492  9532 9146
 602 |          9147 9472 9148 9149 9500 9508 9524 9516
 603 |          9474 8804 8805 960 8800 163 183)))
 604 | 
 605 | ;; fixme: move attr to keyword args instead of allocating a tmp object?
 606 | (defun tsetchar (c attr x y &key (term *term*))
 607 |   (when (and (eq (aref (translation-table term)
 608 |                        (charset term))
 609 |                  :cs-graphic0)
 610 |              (< #x41 (char-code c) #x7e))
 611 |     (setf c (aref *vt100-0* (- (char-code c) #x41))))
 612 |   (if (logtest +attr-wide+ (mode (glyph-at (screen term) y x)))
 613 |       (when (< (1+ x) (columns term))
 614 |         (setf (c (glyph-at (screen term) y (1+ x))) #\space
 615 |               (mode (glyph-at (screen term) y (1+ x)))
 616 |               (logxor (mode (glyph-at (screen term) y (1+ x)))
 617 |                       +attr-wdummy+)))
 618 |       (when (logtest +attr-wdummy+ (mode (glyph-at (screen term) y x)))
 619 |         (setf (c (glyph-at (screen term) y (1- x))) #\space
 620 |               (mode (glyph-at (screen term) y (1- x)))
 621 |               (logxor (mode (glyph-at (screen term) y (1- x)))
 622 |                       +attr-wide+))))
 623 |   (setf (aref (dirty term) y) 1)
 624 |   (let ((g (glyph-at (screen term) y x)))
 625 |     #++(format t "~& ~a @ ~a ~a (~a -> " c x y (c g))
 626 |     (setf (c g) c
 627 |           (mode g) (mode attr)
 628 |           (fg g) (fg attr)
 629 |           (bg g) (bg attr))
 630 |     #++(format t "~a / ~a)~%" (c g)
 631 |                (c (aref (aref (screen *term*) y) x)))))
 632 | 
 633 | 
 634 | (defun tclearregion (x1 y1 x2 y2 &key (term *term*))
 635 |   (when (> x1 x2)
 636 |     (rotatef x1 x2))
 637 |   (when (> y1 y2)
 638 |     (rotatef y1 y2))
 639 |   (setf x1 (limit x1 0 (1- (columns term)))
 640 |         x2 (limit x2 0 (1- (columns term)))
 641 |         y1 (limit y1 0 (1- (rows term)))
 642 |         y2 (limit y2 0 (1- (rows term))))
 643 |   (loop for y from y1 to y2
 644 |      do (setf (aref (dirty term) y) 1)
 645 |        (loop for x from x1 to x2
 646 |           for g = (glyph-at (screen term) y x)
 647 |           do #++(when (selected x y)
 648 |                   (selclear nil))
 649 |             (setf (fg g) (fg (attributes (cursor term)))
 650 |                   (bg g) (bg (attributes (cursor term)))
 651 |                   (mode g) 0
 652 |                   (c g) #\space))))
 653 | 
 654 | (defun tdeletechar (n &key (term *term*))
 655 |   (limitf n 0 (- (columns term) (x (cursor term))))
 656 |   (let* ((dest (x (cursor term)))
 657 |          (source (+ dest n))
 658 |          (line (aref (screen term) (y (cursor term)))))
 659 |     (move-glyphs line :start1 dest :start2 source :end2 (columns term))
 660 |     (tclearregion (- (columns term) n) (y (cursor term))
 661 |                   (1- (columns term)) (y (cursor term)))))
 662 | 
 663 | (defun tinsertblank (n &key (term *term*))
 664 |   (limitf n 0 (- (columns term) (x (cursor term))))
 665 |   (let* ((source (x (cursor term)))
 666 |          (dest (+ source n))
 667 |          (line (aref (screen term) (y (cursor term)))))
 668 |     (move-glyphs line :start1 dest :start2 source :end1 (columns term))
 669 |     (tclearregion source (y (cursor term))
 670 |                   (1- dest) (y (cursor term)))))
 671 | 
 672 | (defun tinsertblankline (n &key (term *term*))
 673 |   (when (<= (top term) (y (cursor term)) (bottom term))
 674 |     (tscrolldown (y (cursor term)) n :term term)))
 675 | 
 676 | (defun tdeleteline (n &key (term *term*))
 677 |   (when (<= (top term) (y (cursor term)) (bottom term))
 678 |     (tscrollup (y (cursor term)) n :term term)))
 679 | 
 680 | 
 681 | (defun tdefcolor (attributes start)
 682 |   (case (aref attributes (1+ start))
 683 |     (2 ;; direct color in RGB space
 684 |      (when (> (+ start 4) (length attributes))
 685 |        (warn "erresc(38): Incorrect number of parameters (~a)" start)
 686 |        (return-from tdefcolor (values -1 start)))
 687 |      (let ((r (aref attributes (+ start 2)))
 688 |            (g (aref attributes (+ start 3)))
 689 |            (b (aref attributes (+ start 4))))
 690 |        (incf start 4)
 691 |        (if (not (and (<= 0 r 255) (<= 0 g 255) (<= 0 b 255)))
 692 |            (warn "erresc: bad rgb color (~a ~a ~a)" r g b)
 693 |            (values (truecolor r g b) start))))
 694 |     (5 ;; indexed color
 695 |      (when (> (+ start 2) (length attributes))
 696 |        (warn "erresc(38): Incorrect number of parameters (~a)" start)
 697 |        (return-from tdefcolor (values -1 start)))
 698 |      (incf start 2)
 699 |      (if (not (<= 0 (aref attributes start) 255))
 700 |          (warn "erresc: bad color ~a" (aref attributes start))
 701 |          (values (aref attributes start) start)))
 702 |     ((0 ;; implemented defined (only foreground)
 703 |       1 ;; transparent
 704 |       3 ;; direct color in CMY space
 705 |       4 ;; direct color in CMYK space
 706 |       t)
 707 |      (warn "erresc(38): gfx attr ~a/~a unknown" (aref attributes start)
 708 |            (aref attributes (1+ start)))
 709 |      (values -1 start))))
 710 | 
 711 | (defun tsetattr (attributes &key (term *term*))
 712 |   (loop with attr = (attributes (cursor term))
 713 |      ;; can't use from 1 to x because we skip more than 1 sometimes
 714 |      for i = 0 then (1+ i)
 715 |      while (< i (length attributes))
 716 |      do (flet ((on (&rest a)
 717 |                  (setf (mode attr) (apply #'logior (mode attr) a)))
 718 |                (off (&rest a)
 719 |                  (setf (mode attr) (logandc2 (mode attr)
 720 |                                              (apply #'logior a)))))
 721 |           (case (aref attributes i)
 722 |             (0
 723 |              (off +ATTR-BOLD+
 724 |                   +ATTR-FAINT+
 725 |                   +ATTR-ITALIC+
 726 |                   +ATTR-UNDERLINE+
 727 |                   +ATTR-BLINK+
 728 |                   +ATTR-REVERSE+
 729 |                   +ATTR-INVISIBLE+
 730 |                   +ATTR-STRUCK+)
 731 |              (setf (fg attr) *default-foreground*
 732 |                    (bg attr) *default-background*))
 733 |             (1 (on +attr-bold+))
 734 |             (2 (on +attr-faint+))
 735 |             (3 (on +attr-italic+))
 736 |             (4 (on +attr-underline+))
 737 |             (5 (on +attr-blink+)) ;; slow blink
 738 |             (6 (on +attr-blink+)) ;; rapid blink
 739 |             (7 (on +attr-reverse+))
 740 |             (8 (on +attr-invisible+))
 741 |             (9 (on +attr-struck+))
 742 |             ;; 10 = primary font
 743 |             ;; 11-19 = alternate fonts
 744 |             ;; 20 = fraktur font
 745 |             (21 (off +attr-bold+)) ;; bold off or underline double?
 746 |             (22 (off +attr-bold+ +attr-faint+))
 747 |             (23 (off +attr-italic+))
 748 |             (24 (off +attr-underline+))
 749 |             (25 (off +attr-blink+))
 750 |             ;; 26 reserved
 751 |             (27 (off +attr-reverse+))
 752 |             (28 (off +attr-invisible+))
 753 |             (29 (off +attr-struck+))
 754 |             ;; 30-37 below
 755 |             (38 (multiple-value-bind (index next-i)
 756 |                     (tdefcolor attributes i)
 757 |                   (setf (fg attr) index
 758 |                         i next-i)))
 759 |             (39 (setf (fg attr) *default-foreground*))
 760 |             ;; 40-47 below
 761 |             (48 (multiple-value-bind (index next-i)
 762 |                     (tdefcolor attributes i)
 763 |                   (setf (bg attr) index
 764 |                         i next-i)))
 765 |             (49 (setf (bg attr) *default-background*))
 766 |             ;; 50 reserved
 767 |             ;; 51 framed
 768 |             ;; 52 encircled
 769 |             ;; 53 overline
 770 |             ;; 54 not framed or encircled
 771 |             ;; 55 not overlined
 772 |             ;; 56-59 reserved
 773 |             ;; 60-65 ideogram underline/overline/stress/etc
 774 |             (t
 775 |              (let ((a (aref attributes i)))
 776 |                (cond
 777 |                  ((<= 30 a 37) ;; text color
 778 |                   (setf (fg attr) (- a 30)))
 779 |                  ((<= 40 a 47) ;; bg color
 780 |                   (setf (bg attr) (- a 40)))
 781 |                  ((<= 90 a 97) ;; text color high intensity
 782 |                   (setf (fg attr) (+ 8 (- a 90))))
 783 |                  ((<= 100 a 107) ;; bg color high intensity
 784 |                   (setf (bg attr) (+ 8 (- a 100)))))))))))
 785 | 
 786 | (defun tsetscroll (top bottom &key (term *term*))
 787 |   (limitf top 0 (1- (rows term)))
 788 |   (limitf bottom 0 (1- (rows term)))
 789 |   (when (> top bottom)
 790 |     (rotatef top bottom))
 791 |   (setf (top term) top
 792 |         (bottom term) bottom))
 793 | 
 794 | (defun tsetmode (priv set args &key (term *term*))
 795 |   (setf set (and set (not (zerop set))))
 796 |                                         ;  (break "tsetmode ~s ~s ~s ~s" priv set args term)
 797 |   (loop for arg across args
 798 |      if priv
 799 |      do (case arg
 800 |           (1 ;; DECCKM -- Cursor key
 801 |            (modbit (mode term) set +mode-appcursor+))
 802 |           (5 ;; DECSCNM -- Reverse video
 803 |            (let ((old (mode term)))
 804 |              (modbit (mode term) set +mode-reverse+)
 805 |              (unless (= old (mode term))
 806 |                ;; not sure if this needs timeout?
 807 |                ;; probably should be handled differently if it does
 808 |                #++(redraw *redraw-timeout* :term term))))
 809 |           (6 ;; DECOM -- Origin
 810 |            (modbit (state (cursor term)) set +cursor-origin+)
 811 |            (tmoveato 0 0 :term term))
 812 |           (7 ;; DECAWM -- Auto wrap
 813 |            (modbit (mode term) set +mode-wrap+))
 814 |           ((0 ;; Error (IGNORED)
 815 |             2 ;; DECANM -- ANSI/VT52 (IGNORED)
 816 |             3 ;; DECCOLM -- Column  (IGNORED)
 817 |             4 ;; DECSCLM -- Scroll (IGNORED)
 818 |             8 ;; DECARM -- Auto repeat (IGNORED)
 819 |             18 ;; DECPFF -- Printer feed (IGNORED)
 820 |             19 ;; DECPEX -- Printer extent (IGNORED)
 821 |             42 ;; DECNRCM -- National characters (IGNORED)
 822 |             12)) ;; att610 -- Start blinking cursor (IGNORED)
 823 |           (25 ;; DECTCEM -- Text Cursor Enable Mode
 824 |            (modbit (mode term) (not set) +mode-hide+))
 825 |           (9 ;; X10 mouse compatibility mode
 826 |            #++ (xsetpointermotion nil :term term)
 827 |            (modbit (mode term) nil +mode-mouse+)
 828 |            (modbit (mode term) set +mode-mousex10+))
 829 |           (1000 ;;1000: report button press
 830 |            #++(xsetpointermotion nil :term term)
 831 |            (modbit (mode term) nil +mode-mouse+)
 832 |            (modbit (mode term) set +mode-mousebtn+))
 833 |           (1002 ;; 1002: report motion on button press
 834 |            #++(xsetpointermotion nil :term term)
 835 |            (modbit (mode term) nil +mode-mouse+)
 836 |            (modbit (mode term) set +mode-mousemotion+))
 837 |           (1003 ;; 1003: enable all mouse motions
 838 |            #++(xsetpointermotion set :term term)
 839 |            (modbit (mode term) nil +mode-mouse+)
 840 |            (modbit (mode term) set +mode-mousemany+))
 841 |           (1004 ;; 1004: send focus events to tty
 842 |            (modbit (mode term) set +mode-focus+))
 843 |           (1006 ;; 1006: extended reporting mode
 844 |            (modbit (mode term) set +mode-mousesgr+))
 845 |           (1034
 846 |            (modbit (mode term) set +mode-8bit+))
 847 |           ((1049 ;; swap screen & set/restore cursor as xterm
 848 |             47 ;; swap screen
 849 |             1047
 850 |             1048)
 851 |            (when (and (eql arg 1049)
 852 |                       (allow-alt-screen term))
 853 |              (tcursor (if set :cursor-save :cursor-load)
 854 |                       :term term))
 855 |            (when (member arg '(1049 47 1047))
 856 |              (when (allow-alt-screen term)
 857 |                (let ((alt (logtest (mode term) +mode-altscreen+)))
 858 |                  (when alt
 859 |                    (tclearregion 0 0 (1- (columns term)) (1- (rows term))
 860 |                                  :term term))
 861 |                  (unless (eql set alt)
 862 |                    (tswapscreen :term term)))))
 863 |            (when (member arg '(1049 1048))
 864 |              (tcursor (if set :cursor-save :cursor-load)
 865 |                       :term term)))
 866 |           (2004 ;; 2004: bracketed paste mode
 867 |            (modbit (mode term) set +mode-brcktpaste+))
 868 |           ;; Not implemented mouse modes. See comments there.
 869 |           ((;; mouse highlight mode; can hang the terminal by
 870 |             ;; design when implemented.
 871 |             1001
 872 |             ;; UTF-8 mouse mode; will confuse applications not
 873 |             ;; supporting UTF-8 and luit.
 874 |             1005
 875 |             ;; urxvt mangled mouse mode; incompatible and can be
 876 |             ;; mistaken for other control codes.
 877 |             1015))
 878 |           (t
 879 |            (warn "unknown private set/reset mode ~a" arg)))
 880 |      else do
 881 |        (case arg
 882 |          (0 ;; Error (IGNORED)
 883 |           )
 884 |          (2 ;; KAM -- keyboard action
 885 |           (modbit (mode term) set +mode-kbdlock+))
 886 |          (4 ;;IRM -- Insertion-replacement
 887 |           (modbit (mode term) set +mode-insert+))
 888 |          (12 ;; SRM -- Send/Receive
 889 |           (modbit (mode term) (not set) +mode-echo+))
 890 |          (20 ;;LNM -- Linefeed/new line
 891 |           (modbit (mode term) set +mode-crlf+))
 892 |          (t
 893 |           (warn "erresc: unknown set/reset mode ~a" arg)))))
 894 | 
 895 | (defun csihandle (csi &key (term *term*))
 896 |   (flet ((unknown ()
 897 |            (warn "erresc: unknown csi ~a"
 898 |                  (csidump csi :term term))
 899 |            ;; die("");
 900 |            ))
 901 |     (case (mode csi)
 902 |       (#\@ ;; ICH -- Insert <n> blank char
 903 |        (ensure-aref (arguments csi) 0 1))
 904 |       (#\A ;; CUU -- Cursor <n> Up
 905 |        (ensure-aref (arguments csi) 0 1)
 906 |        (tmoveto (x (cursor term))
 907 |                 (- (y (cursor term)) (aref (arguments csi) 0))
 908 |                 :term term))
 909 |       ((#\B ;; CUD -- Cursor <n> Down
 910 |         #\e) ;; VPR --Cursor <n> Down
 911 |        (ensure-aref (arguments csi) 0 1)
 912 |        (tmoveto (x (cursor term))
 913 |                 (+ (y (cursor term))
 914 |                    (aref (arguments csi) 0))
 915 |                 :term term))
 916 |       (#\i ;; MC -- Media Copy
 917 |        ;; not sure if it should error or default here?
 918 |        (ensure-aref (arguments csi) 0 0)
 919 |        (case (aref (arguments csi) 0)
 920 |          (0 (tdump :term term))
 921 |          (1 (tdumpline (y (cursor term)) :term term))
 922 |          (2 #++(tdumpsel :term term))
 923 |          (4 (modbit (mode term) nil +mode-print+))
 924 |          (5 (modbit (mode term) t +mode-print+))))
 925 |       (#\c ;; DA -- Device Attributes
 926 |        (when (zerop (aref (arguments csi) 0))
 927 |          (tty-write *vt-iden* :term term)))
 928 |       ((#\C ;; CUF -- Cursor <n> Forward
 929 |         #\a) ;; HPR -- Cursor <n> Forward
 930 |        (ensure-aref (arguments csi) 0 1)
 931 |        (tmoveto (+ (x (cursor term))
 932 |                    (aref (arguments csi) 0))
 933 |                 (y (cursor term))
 934 |                 :term term))
 935 |       (#\D ;; CUB -- Cursor <n> Backward
 936 |        (ensure-aref (arguments csi) 0 1)
 937 |        (tmoveto (- (x (cursor term))
 938 |                    (aref (arguments csi) 0))
 939 |                 (y (cursor term))
 940 |                 :term term))
 941 |       (#\E ;; CNL -- Cursor <n> Down and first col
 942 |        (ensure-aref (arguments csi) 0 1)
 943 |        (tmoveto 0 (+ (y (cursor term))
 944 |                      (aref (arguments csi) 0))
 945 |                 :term term))
 946 |       (#\F ;; CPL -- Cursor <n> Up and first col
 947 |        (ensure-aref (arguments csi) 0 1)
 948 |        (tmoveto 0 (- (y (cursor term))
 949 |                      (aref (arguments csi) 0))
 950 |                 :term term))
 951 |       (#\g ;; TBC -- Tabulation clear
 952 |        ;; not sure if it should error or default here?
 953 |        (ensure-aref (arguments csi) 0 0)
 954 |        (case (aref (arguments csi) 0)
 955 |          (0 ;; clear current tab stop
 956 |           (setf (aref (tabs term) (x (cursor term))) 0))
 957 |          (3 ;; clear all the tabs
 958 |           (fill (tabs term) 0))
 959 |          (t
 960 |           (unknown)))
 961 |        )
 962 | 
 963 |       ((#\G ;; CHA -- Move to <col>
 964 |         #\`);; HPA
 965 |        (ensure-aref (arguments csi) 0 1)
 966 |        (tmoveto (1- (aref (arguments csi) 0))
 967 |                 (y (cursor term))
 968 |                 :term term))
 969 |       ((#\H ;; CUP -- Move to <row> <col>
 970 |         #\f);; HVP
 971 |        (ensure-aref (arguments csi) 0 1)
 972 |        (ensure-aref (arguments csi) 1 1)
 973 |        (tmoveato (1- (aref (arguments csi) 1))
 974 |                  (1- (aref (arguments csi) 0))))
 975 |       (#\I ;; CHT -- Cursor Forward Tabulation <n> tab stops
 976 |        (ensure-aref (arguments csi) 0 1)
 977 |        (tputtab (aref (arguments csi) 0) :term term))
 978 |       (#\J ;; ED -- Clear screen
 979 |        #++(selclear nil :term term)
 980 |        ;; not sure if it should error or default here?
 981 |        (ensure-aref (arguments csi) 0 0)
 982 |        (case (aref (arguments csi) 0)
 983 |          (0 ;; below
 984 |           (tclearregion (x (cursor term)) (y (cursor term))
 985 |                         (1- (columns term)) (y (cursor term))
 986 |                         :term term)
 987 |           (when (< (y (cursor term)) (1- (rows term)))
 988 |             (tclearregion 0 (1+ (y (cursor term)))
 989 |                           (1- (columns term)) (1- (rows term))
 990 |                           :term term)))
 991 |          (1 ;; above
 992 |           (when (> (y (cursor term)) 1)
 993 |             (tclearregion 0 0 (1- (columns term)) (1- (y (cursor term)))
 994 |                           :term term))
 995 |           (tclearregion 0 (y (cursor term))
 996 |                         (x (cursor term)) (y (cursor term))
 997 |                         :term term))
 998 |          (2 ;; all
 999 |           (tclearregion 0 0 (1- (columns term)) (1- (rows term))
1000 |                         :term term))
1001 |          (t (unknown))))
1002 |       (#\K ;; EL -- Clear line
1003 |        ;; not sure if it should error or default here?
1004 |        (ensure-aref (arguments csi) 0 0)
1005 |        (case (aref (arguments csi) 0)
1006 |          (0 ;; right
1007 |           (tclearregion (x (cursor term)) (y (cursor term))
1008 |                         (1- (columns term)) (y (cursor term))
1009 |                         :term term))
1010 |          (1 ;; left
1011 |           (tclearregion 0 (y (cursor term))
1012 |                         (x (cursor term)) (y (cursor term))
1013 |                         :term term))
1014 |          (2 ;; all
1015 |           (tclearregion 0 (y (cursor term))
1016 |                         (1- (columns term)) (y (cursor term))
1017 |                         :term term))
1018 |          (t (unknown))))
1019 |       (#\S ;; SU -- Scroll <n> line up
1020 |        (ensure-aref (arguments csi) 0 1)
1021 |        (tscrollup (top term) (aref (arguments csi) 0)
1022 |                   :term term))
1023 |       (#\T ;; SD -- Scroll <n> line down
1024 |        (ensure-aref (arguments csi) 0 1)
1025 |        (tscrolldown (top term) (aref (arguments csi) 0)
1026 |                     :term term))
1027 |       (#\L ;; IL -- Insert <n> blank lin
1028 |        (ensure-aref (arguments csi) 0 1)
1029 |        (tinsertblankline (aref (arguments csi) 0) :term term))
1030 |       (#\l ;; RM -- Reset Mode
1031 |        (tsetmode (priv csi) 0 (arguments csi) :term term))
1032 |       (#\M ;; DL -- Delete <n> lines
1033 |        (ensure-aref (arguments csi) 0 1)
1034 |        (tdeleteline (aref (arguments csi) 0) :term term))
1035 |       (#\X ;; ECH -- Erase <n> char
1036 |        (ensure-aref (arguments csi) 0 1)
1037 |        (tclearregion (x (cursor term)) (y (cursor term))
1038 |                      (+ (x (cursor term)) (aref (arguments csi) 0) -1)
1039 |                      (y (cursor term))
1040 |                      :term term))
1041 |       (#\P ;; DCH -- Delete <n> char
1042 |        (ensure-aref (arguments csi) 0 1)
1043 |        (tdeletechar (aref (arguments csi) 0) :term term))
1044 |       (#\Z ;; CBT -- Cursor Backward Tabulation <n> tab stops
1045 |        (ensure-aref (arguments csi) 0 1)
1046 |        (tputtab (- (aref (arguments csi) 0)) :term term))
1047 |       (#\d ;; VPA -- Move to <row>
1048 |        (ensure-aref (arguments csi) 0 1)
1049 |        (tmoveto (x (cursor term)) (1- (aref (arguments csi) 0))
1050 |                 :term term))
1051 |       (#\h ;; SM -- Set terminal mode
1052 |        (tsetmode (priv csi) 1 (arguments csi) :term term))
1053 |       (#\m ;; SGR -- Terminal attribute (color)
1054 |        (tsetattr (arguments csi) :term term))
1055 |       (#\n ;; DSR – Device Status Report (cursor position)
1056 |        ;; fixme: check size instead of defaulting to zero?
1057 |        (ensure-aref (arguments csi) 0 0)
1058 |        (when (zerop (aref (arguments csi) 0))
1059 |          (tty-write (format nil "~c[~d,~dR" (code-char #o33)
1060 |                             (1+ (y (cursor term)))
1061 |                             (1+ (x (cursor term))))
1062 |                     :term term)))
1063 |       (#\r ;; DECSTBM -- Set Scrolling Region
1064 |        (if (priv csi)
1065 |            (unknown)
1066 |            (progn
1067 |              (ensure-aref (arguments csi) 0 1)
1068 |              (ensure-aref (arguments csi) 1 (rows term))
1069 |              (tsetscroll (1- (aref (arguments csi) 0))
1070 |                          (1- (aref (arguments csi) 1))
1071 |                          :term term)
1072 |              (tmoveto 0 0 :term term))))
1073 |       (#\s ;; DECSC -- Save cursor position (ANSI.SYS)
1074 |        (tcursor :cursor-save :term term))
1075 |       (#\u ;; DECRC -- Restore cursor position (ANSI.SYS)
1076 |        (tcursor :cursor-load :term term))
1077 |       (t (unknown)))))
1078 | 
1079 | (defun csidump (csi &key (term *term*))
1080 |   (declare (ignore term))
1081 |   (with-output-to-string (*standard-output*)
1082 |     (format t "ESC[")
1083 |     (loop for c across (buffer csi)
1084 |        if (graphic-char-p c)
1085 |        do (format t "~c" c)
1086 |        else if (char= c #\newline)
1087 |        do (format t "\\n")
1088 |        else if (char= c #\return)
1089 |        do (format t "\\r")
1090 |        else if (char= c (code-char #x1b))
1091 |        do (format t "\\e")
1092 |        else do (format t "(~2,'0x)" (char-code c)))))
1093 | 
1094 | (defun csireset (csi)
1095 |   (setf (fill-pointer (buffer csi)) 0
1096 |         (priv csi) nil
1097 |         (fill-pointer (arguments csi)) 0
1098 |         (mode csi) 0))
1099 | 
1100 | (defun strhandle (str &key (term *term*))
1101 |   (setf (escape term) (logandc2 (escape term)
1102 |                                 (logior +esc-str-end+ +esc-str+)))
1103 |   (loop for a in (split-sequence:split-sequence #\; (buffer str))
1104 |      do (vector-push-extend a (arguments str)))
1105 |   #++(strparse esc)
1106 |   (let* ((args (arguments str))
1107 |          (par (if (equal (aref args 0) "")
1108 |                   0
1109 |                   (parse-integer (aref args 0))))
1110 |          (narg (length args)))
1111 |     (case (str-type str)
1112 |       (#\] ;; OSC -- Operating System Command
1113 |        (case par
1114 |          ((0 1 2)
1115 |           (when (> narg 1)
1116 |             (let ((set-title (on-set-title term)))
1117 |               (if set-title
1118 |                   (funcall set-title term (aref args 1))))
1119 |             #++(xsettitle (aref args 1))))
1120 |          ((4 ;; color set
1121 |            104);; color reset
1122 |           (when (or (= par 104)
1123 |                     (>= narg 3))
1124 |             (let ((p (when (= par 4)
1125 |                        (aref args 2)))
1126 |                   (j (if (> narg 1)
1127 |                          (or (parse-integer (aref args 1) :junk-allowed t) 0)
1128 |                          -1)))
1129 |               (declare (ignorable p j))
1130 |               #++(if (xsetcolorname j p)
1131 |                      (warn "erresc: invalid color ~a" p)
1132 |                      ;; TODO if defaultbg color is changed, borders are
1133 |                      ;; dirty
1134 |                      (redraw 0 :term term)))))))
1135 |       (#\k ;; old title set compatibility
1136 |        #++ (xsettitle (aref args 0)))
1137 |       ((#\P ;; DCS -- Device Control String
1138 |         #\- ;; APC -- Application Program Command
1139 |         #\^);;PM -- Privacy Message
1140 |        ;; ignore
1141 |        )
1142 |       (t
1143 |        (warn "erresc: unknown str ~a" (strdump (str-escape term)))))))
1144 | 
1145 | (defun strdump (str)
1146 |   (with-output-to-string (*standard-output*)
1147 |     (format t "ESC~c" (str-type str))
1148 |     (loop for c across (buffer str)
1149 |        if (graphic-char-p c)
1150 |        do (format t "~c" c)
1151 |        else if (char= c #\newline)
1152 |        do (format t "\\n")
1153 |        else if (char= c #\return)
1154 |        do (format t "\\r")
1155 |        else if (char= c (code-char #x1b))
1156 |        do (format t "\\e")
1157 |        else do (format t "(~2,'0x)" (char-code c)))
1158 |     (format t "ESC")))
1159 | 
1160 | (defun strreset (str)
1161 |   ;; fixme: move this to reinitialize-instance?
1162 |   (setf (fill-pointer (buffer str)) 0
1163 |         (priv str) nil
1164 |         (fill-pointer (arguments str)) 0
1165 |         (str-type str) (code-char 0)))
1166 | 
1167 | (defun tprinter (string &key (term *term*))
1168 |   (declare (ignore term))
1169 |   ;; todo: make output stream configurable?
1170 |   (format *standard-output* "-~a-" string)
1171 |   ;;  if(iofd != -1 && xwrite(iofd, s, len) < 0) {
1172 |   ;;    fprintf(stderr, "Error writing in %s:%s\n",
1173 |   ;;            opt-io, strerror(errno));
1174 |   ;;    close(iofd);
1175 |   ;;    iofd = -1;
1176 |   ;;  }
1177 |   )
1178 | 
1179 | ;;; these are used for keybindings, possibly should return a closure instead
1180 | ;;; if still being used that way?
1181 | (defun toggleprinter (arg &key (term *term*))
1182 |   (declare (ignore arg))
1183 |   (setf (mode term) (logxor (mode term) +mode-print+)))
1184 | 
1185 | (defun printscreem (arg &key (term *term*))
1186 |   (declare (ignore arg))
1187 |   (tdump :term term))
1188 | 
1189 | (defun printsel (arg &key (term *term*))
1190 |   (declare (ignore arg term))
1191 |   #++(tdumpsel :term term))
1192 | 
1193 | #++
1194 | (defun tdumpsel (&key (term *term*))
1195 |   (tprinter (getsel :term term) :term term))
1196 | 
1197 | (defun tdumpline (n &key (term *term*))
1198 |   (let ((line (string-right-trim " " (map 'string #'c (aref (screen term) n)))))
1199 |     (tprinter line :term term)
1200 |     (tprinter (format nil "~%") :term term)))
1201 | 
1202 | (defun tdump (&key (term *term*))
1203 |   (dotimes (i (rows term))
1204 |     (tdumpline i :term term)))
1205 | 
1206 | (defun tputtab (n &key (term *term*))
1207 |   (let ((x (x (cursor term))))
1208 |     (cond
1209 |       ((plusp n)
1210 |        (loop repeat n
1211 |           when (and x (< x (1- (columns term))))
1212 |           do (setf x (position 1 (tabs term) :start (1+ x)))))
1213 |       ((minusp n)
1214 |        (loop repeat (abs n)
1215 |           when (and x (plusp x))
1216 |           do (setf x (position 1 (tabs term) :from-end t :end x)))))
1217 |     (tmoveto (or x (if (plusp n) (1- (columns term)) 0))
1218 |              (y (cursor term)) :term term)))
1219 | 
1220 | (defun techo (string &key (term *term*))
1221 |   (let ((start 0))
1222 |     (loop for c across string
1223 |        for cc = (char-code c)
1224 |        while (control-p cc)
1225 |        do (incf start)
1226 |          (cond
1227 |            ((logtest cc #x80)
1228 |             (setf cc (logand #x7f))
1229 |             (tputc #\^ :term term)
1230 |             (tputc #\[ :term term))
1231 |            ((not (member cc '(9 10 13))) ;; \t \n \r
1232 |             (setf cc (logxor cc #x40))
1233 |             (tputc #\^ :term term)))
1234 |          (tputc (code-char cc) :term term))
1235 |     (loop for i from start below (length string)
1236 |        do (tputc (aref string i) :term term))))
1237 | 
1238 | (defun tdeftran (ascii &key (term *term*))
1239 |   (let ((p (position ascii "0B")))
1240 |     (if p
1241 |         (setf (aref (translation-table term)
1242 |                     (icharset term))
1243 |               (aref #(:cs-graphic0 :cs-usa) p))
1244 |         (warn "esc unhandled charset: ESC ( ~a" ascii))))
1245 | 
1246 | (defun tdectest (c &key (term *term*))
1247 |   (when (eql c #\8)
1248 |     ;; DEC screen alignment test.
1249 |     (loop for x below (columns term)
1250 |        do (loop for y below (rows term)
1251 |              do (tsetchar #\E (attributes (cursor term)) x y
1252 |                           :term term)))))
1253 | 
1254 | (defun tstrsequence (c &key (term *term*))
1255 |   (let ((cc (char-code c)))
1256 |     (when (logtest cc #x80)
1257 |       (case cc
1258 |         (#x90 ;; DCS -- Device Control String
1259 |          (setf c #\P))
1260 |         (#x9f ;; APC -- Application Program Command
1261 |          (setf c #\-))
1262 |         (#x9e ;; PM -- Privacy Message
1263 |          (setf c #\^))
1264 |         (#x9d ;; OSC -- Operating System Command
1265 |          (setf c #\]))))
1266 |     ;; not sure if it is better to reset str-escape or make a new one?
1267 |     (setf (str-escape term) (make-instance 'str-escape :c c))
1268 |     (modbit (escape term) t +esc-str+)))
1269 | 
1270 | (defun tcontrolcode (ascii &key (term *term*))
1271 |   (let ((cc (char-code ascii)))
1272 |     (case cc
1273 |       (9 ;; \t HT
1274 |        (tputtab 1 :term term))
1275 |       (8 ;; \b BS
1276 |        (tmoveto (1- (x (cursor term))) (y (cursor term)) :term term))
1277 |       (13 ;; \r CR
1278 |        (tmoveto 0 (y (cursor term)) :term term))
1279 |       ((12  ;; \f FF
1280 |         11  ;; \v VT
1281 |         10) ;; \n LF
1282 |        ;; go to first col if the mode is set
1283 |        (tnewline (logtest (mode term) +mode-crlf+) :term term))
1284 |       (7 ;; \a BEL
1285 |        (if (logtest +esc-str-end+ (escape term))
1286 |            ;; backwards compatibility to xterm
1287 |            (strhandle (str-escape term) :term term)
1288 |            ;; todo: pass to caller to either play sound or flash term?
1289 |            ))
1290 |       (#o33 ;; ESC
1291 |        ;; fixme: should this reset instead of allocating new one?
1292 |        (setf (csi-escape term) (make-instance 'csi-escape))
1293 |        (setf (escape term) (logior
1294 |                             (logandc2 (escape term)
1295 |                                       (logior +esc-csi+
1296 |                                               +esc-altcharset+
1297 |                                               +esc-test+))
1298 |                             +esc-start+)))
1299 |       ((#o16  ;; SO (LS1 -- Locking shift 1)
1300 |         #o17) ;; SI (LS0 -- Locking shift 0)
1301 |        (setf (charset term) (- 1 (- (char-code ascii) #o16))))
1302 |       (#o32 ;; SUB
1303 |        (tsetchar #\? (attributes (cursor term))
1304 |                  (x (cursor term)) (y (cursor term))
1305 |                  :term term)
1306 |        (setf (csi-escape term) (make-instance 'csi-escape)))
1307 |       (#o30 ;; CAN
1308 |        (setf (csi-escape term) (make-instance 'csi-escape)))
1309 |       ((#o05   ;; ENQ (IGNORED)
1310 |         #o000  ;; NUL (IGNORED)
1311 |         #o021  ;; XON (IGNORED)
1312 |         #o023  ;; XOFF (IGNORED)
1313 |         #o177) ;; DEL (IGNORED)
1314 |        )
1315 |       (#x84 ;; TODO: IND
1316 |        )
1317 |       (#x85 ;; NEL -- Next line
1318 |        (tnewline t :term term)) ; always go to first col
1319 |       (#x88 ;; HTS -- Horizontal tab stop
1320 |        (setf (aref (tabs term) (x (cursor term))) 1))
1321 |       ((#x8d ;; TODO: RI
1322 |         #x8e ;; TODO: SS2
1323 |         #x8f ;; TODO: SS3
1324 |         #x98) ;; TODO: SOS
1325 |        )
1326 |       (#x9a ;; DECID -- Identify Terminal
1327 |        (tty-write *vt-iden* :term term))
1328 |       ((#x9b ;; TODO: CSI
1329 |         #x9c) ;; TODO: ST
1330 |        )
1331 |       ((#x90 ;; DCS -- Device Control String
1332 |         #x9f ;; APC -- Application Program Command
1333 |         #x9e ;; PM -- Privacy Message
1334 |         #x9d) ;; OSC -- Operating System Command
1335 |        (tstrsequence ascii :term term)))
1336 |     ;; only CAN, SUB, \a and C1 chars interrupt a sequence
1337 |     (when (or (= cc 7)
1338 |               (= cc #o30)
1339 |               (controlc1-p cc))
1340 |       (format t "")
1341 |       (setf (escape term) (logandc2 (escape term)
1342 |                                     (logior +esc-str-end+ +esc-str+))))))
1343 | 
1344 | (defun eschandle (ascii &key (term *term*))
1345 |   ;; returns T when the sequence is finished and it hasn't to read
1346 |   ;; more characters for this sequence, otherwise NIL
1347 |   (block nil ;; save typing on all the early returns...
1348 |     (let ((cc (char-code ascii)))
1349 |       (case ascii
1350 |         (#\[
1351 |          (modbit (escape term) t +esc-csi+)
1352 |          (return nil))
1353 |         (#\#
1354 |          (modbit (escape term) t +esc-test+)
1355 |          (return nil))
1356 |         ((#\P ;; DCS -- Device Control String
1357 |           #\_ ;; APC -- Application Program Command
1358 |           #\^ ;; PM -- Privacy Message
1359 |           #\] ;; OSC -- Operating System Command
1360 |           #\k) ;; old title set compatibility
1361 |          (tstrsequence ascii :term term)
1362 |          (return nil))
1363 |         ((#\n ;; LS2 -- Locking shift 2
1364 |           #\o) ;; LS3 -- Locking shift 3
1365 |          (setf (charset term)
1366 |                (+ 2 (- cc (char-code #\n))))
1367 |          (return t))
1368 |         ((#\( ;; GZD4 -- set primary charset G0
1369 |           #\) ;; G1D4 -- set secondary charset G1
1370 |           #\* ;; G2D4 -- set tertiary charset G2
1371 |           #\+) ;; G3D4 -- set quaternary charset G3
1372 |          (setf (icharset term) (- cc (char-code #\()))
1373 |          (modbit (escape term) t +esc-altcharset+)
1374 |          (return nil))
1375 |         (#\D ;; IND -- Linefeed
1376 |          (if (= (bottom term) (y (cursor term)))
1377 |              (tscrollup (top term) 1 :term term)
1378 |              (tmoveto (x (cursor term)) (1+ (y (cursor term)))
1379 |                       :term term))
1380 |          (return t))
1381 |         (#\E ;; NEL -- Next line
1382 |          (tnewline t :term term) ; always go to first col
1383 |          (return t))
1384 |         (#\H ;; HTS -- Horizontal tab stop
1385 |          (setf (aref (tabs term) (x (cursor term))) 1)
1386 |          (return t))
1387 |         (#\M ;; RI -- Reverse index
1388 |          (if (= (top term) (y (cursor term)))
1389 |              (tscrolldown (top term) 1 :term term)
1390 |              (tmoveto (x (cursor term)) (1- (y (cursor term)))
1391 |                       :term term))
1392 |          (return t))
1393 |         (#\Z ;; DECID -- Identify Terminal
1394 |          (tty-write *vt-iden* :term term)
1395 |          (return t))
1396 |         (#\c ;; RIS -- Reset to inital state
1397 |          (treset :term term)
1398 |          ;; todo: xresettitle()
1399 |          ;; todo: xloadcols()
1400 |          (return t))
1401 |         (#\= ;; DECPAM -- Application keypad
1402 |          (modbit (mode term) t +mode-appkeypad+)
1403 |          (return t))
1404 |         (#\> ;; DECPNM -- Normal keypad
1405 |          (modbit (mode term) nil +mode-appkeypad+)
1406 |          (return t))
1407 |         (#\7 ;; DECSC -- Save Cursor
1408 |          (tcursor :cursor-save :term term)
1409 |          (return t)
1410 |          )
1411 |         (#\8 ;; DECRC -- Restore Cursor
1412 |          (tcursor :cursor-load :term term)
1413 |          (return t))
1414 |         (#\\ ;; ST -- String Terminator
1415 |          (when (logtest +esc-str-end+ (escape term))
1416 |            (strhandle (str-escape term))))
1417 |         (t
1418 |          (warn "erresc: unknown sequence ESC ~2,'0x '~c'"
1419 |                cc (if (graphic-char-p ascii) ascii #\.)))))))
1420 | 
1421 | (defun wcwidth (c)
1422 |   (let ((cc (char-code c)))
1423 |     (when (zerop cc)
1424 |       (return-from wcwidth 0))
1425 |     (when (control-p cc)
1426 |       (return-from wcwidth -1))
1427 |     (when (= cc #xad) ;; soft-hyphen
1428 |       (return-from wcwidth 1))
1429 |     (when (member (sb-unicode:general-category c) '(:Mn :Me :Cf))
1430 |       (return-from wcwidth 0))
1431 |     (when (= cc #x200b) ;; zero width space
1432 |       (return-from wcwidth 0))
1433 |     (when (<= #x1160 cc #x11ff) ;; hangul jamo medial vowels, final consonents
1434 |       (return-from wcwidth 0))
1435 |     (when (member (sb-unicode:east-asian-width c) '(:w :f))
1436 |       (return-from wcwidth 2))
1437 |     1))
1438 | 
1439 | (defun tputc (c &key (term *term*))
1440 |   (let* ((cc (char-code c))
1441 |          (width 1)
1442 |          (controlp nil))
1443 |     (when (> cc 255)
1444 |       (setf width (wcwidth c))
1445 |       (when (minusp width)
1446 |         (setf c (code-char #xfffd) ;; #\REPLACEMENT_CHARACTER
1447 |               width 1)
1448 |         (setf controlp (controlc1-p cc))))
1449 |     (when (logtest (mode term) +mode-print+)
1450 |       (tprinter c :term term))
1451 |     (setf controlp (control-p cc))
1452 | 
1453 |     ;; STR sequence must be checked before anything else because it
1454 |     ;; uses all following characters until it receives a ESC, a SUB, a
1455 |     ;; ST or any other C1 control character.
1456 |     (when (logtest +esc-str+ (escape term))
1457 |       (cond
1458 |         ((and (= width 1)
1459 |               (or (member cc '(7 #o30 #o32 #o33))
1460 |                   (controlc1-p cc)))
1461 |          (modbit (escape term) nil (logior +esc-start+ +esc-str+))
1462 |          (modbit (escape term) t +esc-str-end+))
1463 |         ((< (length (buffer (str-escape term))) +str-buf-max-size+)
1464 |          (vector-push-extend c (buffer (str-escape term)))
1465 |          (return-from tputc nil))
1466 |         (t
1467 |          ;; Here is a bug in terminals. If the user never sends some
1468 |          ;; code to stop the str or esc command, then st will stop
1469 |          ;; responding. But this is better than silently failing with
1470 |          ;; unknown characters. At least then users will report back.
1471 | 
1472 |          ;; In the case users ever get fixed, here is the code:
1473 |          ;; (seft (escape term) 0)
1474 |          ;; (strhandle :term term)
1475 |          (return-from tputc nil))))
1476 |     ;; Actions of control codes must be performed as soon they arrive
1477 |     ;; because they can be embedded inside a control sequence, and
1478 |     ;; they must not cause conflicts with sequences.
1479 |     (cond
1480 |       (controlp
1481 |        (tcontrolcode c :term term)
1482 |        ;; control codes are not shown ever
1483 |        (return-from tputc nil))
1484 |       ((logtest +esc-start+ (escape term))
1485 |        (cond
1486 |          ((logtest +esc-csi+ (escape term))
1487 |           (vector-push-extend c (buffer (csi-escape term)))
1488 |           (when (or (<= #x40 cc #x7e)
1489 |                     (> (length (buffer (csi-escape term)))
1490 |                        +csi-buf-max-size+))
1491 |             (setf (escape term) 0)
1492 |             (csiparse (csi-escape term))
1493 |             (csihandle (csi-escape term) :term term))
1494 |           (return-from tputc nil))
1495 |          ((logtest +esc-altcharset+ (escape term))
1496 |           (tdeftran c :term term))
1497 |          ((logtest +esc-test+ (escape term))
1498 |           (tdectest c :term term))
1499 |          (t
1500 |           (unless (eschandle c :term term)
1501 |             (return-from tputc nil))
1502 |           ;; sequence already finished
1503 |           ))
1504 |        (setf (escape term) 0)
1505 |        ;; All characters which form part of a sequence are not printed
1506 |        (return-from tputc nil)))
1507 |     #++(format t "~c" c)
1508 |     ;; todo:
1509 |     ;; if(sel.ob.x != -1 && BETWEEN(term.c.y, sel.ob.y, sel.oe.y))
1510 |     ;;   selclear(NULL);
1511 |     (let ((glyph (glyph-at (screen term) (y (cursor term)) (x (cursor term))))
1512 |           (line (aref (screen term) (y (cursor term)))))
1513 |       (when (and (logtest +mode-wrap+ (mode term))
1514 |                  (logtest +cursor-wrap-next+ (state (cursor term))))
1515 |         (modbit (mode glyph) t +attr-wrap+)
1516 |         (tnewline 1 :term term))
1517 |       (when (and (logtest +mode-insert+ (mode term))
1518 |                  (< (+ width (x (cursor term)))
1519 |                     (columns term)))
1520 |         (move-glyphs line :start1 (+ width (x (cursor term)))
1521 |                      :start2 (x (cursor term))))
1522 |       (when (> (+ width (x (cursor term))) (columns term))
1523 |         (tnewline 1 :term term))
1524 |       (tsetchar c (attributes (cursor term))
1525 |                 (x (cursor term)) (y (cursor term))
1526 |                 :term term)
1527 |       (when (= width 2)
1528 |         (modbit (mode glyph) t +attr-wide+)
1529 |         (when (< (1+ (x (cursor term))) (columns term))
1530 |           (let ((g1 (glyph-at (screen term) (y (cursor term)) (1+ (x (cursor term))))))
1531 |             (setf (c g1) (code-char 0))
1532 |             (setf (mode g1) +attr-wdummy+))))
1533 |       (if (< (+ width (x (cursor term))) (columns term))
1534 |           (tmoveto (+ width (x (cursor term))) (y (cursor term)))
1535 |           (modbit (state (cursor term)) t +cursor-wrap-next+)))))
1536 | 
1537 | 
1538 | (defun tresize (columns rows &key (term *term*))
1539 |   (let ((minrow (min rows (rows term)))
1540 |         (mincol (min columns (columns term)))
1541 |         (slide (1+ (- (y (cursor term)) rows))))
1542 |     (when (or (< columns 1) (< rows 1))
1543 |       (warn "tresize: error resizing to ~ax~a" rows columns)
1544 |       (return-from tresize nil))
1545 |     ;; free uneeded rows
1546 |     (when (plusp slide)
1547 |       ;; slide screen to keep cursor where we expect it - tscrollup
1548 |       ;; would work here, but we can optimize to memmove because we're
1549 |       ;; freeing the earlier lines
1550 |       (replace (screen term) (screen term) :start1 slide :start2 0)
1551 |       (replace (alternate-screen term) (alternate-screen term)
1552 |                :start1 slide :start2 0))
1553 |     ;; possibly should make these adjustable arrays?
1554 |     (setf (slot-value term 'screen) (adjust-array (screen term) rows))
1555 |     (setf (slot-value term 'alternate-screen)
1556 |           (adjust-array (alternate-screen term) rows))
1557 |     ;; don't need to copy DIRTY array since we flag it all later
1558 |     (setf (slot-value term 'dirty) (adjust-array (dirty term) rows))
1559 |     (setf (slot-value term 'tabs ) (adjust-array (tabs term) columns
1560 |                                                  :initial-element 0))
1561 | 
1562 |     ;; resize each row to new width, zero-pad if needed
1563 |     (loop for i below minrow
1564 |        do (flet ((r (s)
1565 |                    (setf (aref s i)
1566 |                          (adjust-array (aref s i) columns))
1567 |                    (loop for j from mincol below columns
1568 |                       do (setf (aref (aref s i) j)
1569 |                                (make-instance 'glyph)))))
1570 |             (r (screen term))
1571 |             (r (alternate-screen term))))
1572 |     ;; allocate any new rows
1573 |     (loop for i from minrow below rows
1574 |        do (flet ((n (s)
1575 |                    (setf (aref s i)
1576 |                          (make-array columns
1577 |                                      :element-type '(vector glyph *)
1578 |                                      :initial-contents
1579 |                                      (coerce
1580 |                                       (loop repeat columns
1581 |                                          collect (make-instance 'glyph))
1582 |                                       '(vector glyph))))))
1583 |             (n (screen term))
1584 |             (n (alternate-screen term))))
1585 |     (when (> columns (columns term))
1586 |       (loop with last-tab = (position 1 (tabs term) :from-end t)
1587 |          for i from (+ *tab-spaces* (or last-tab 0))
1588 |          below columns by *tab-spaces*
1589 |          do (setf (aref (tabs term) i) 1)))
1590 |     ;; update terminal size
1591 |     (setf (slot-value term 'columns) columns
1592 |           (slot-value term 'rows) rows)
1593 |     ;; reset scrolling region
1594 |     (tsetscroll 0 (1- rows) :term term)
1595 |     ;; make use of the LIMIT in tmoveto
1596 |     (tmoveto (x (cursor term)) (y (cursor term)))
1597 |     ;; Clearing both screens (it makes dirty all lines)
1598 |     (let ((c (cursor term)))
1599 |       (loop repeat 2
1600 |          do (when (and (< mincol columns) (< 0 minrow))
1601 |               (tclearregion mincol 0 (1- columns) (1- minrow) :term term))
1602 |            (when (and (< 0 columns) (< minrow rows))
1603 |              (tclearregion 0 minrow (1- columns) (1- rows) :term term))
1604 |            (tswapscreen :term term)
1605 |            (tcursor :cursor-load :term term))
1606 |       (if (>= (x c) columns) (setf (x c) (1- columns)))
1607 |       (if (>= (y c) rows) (setf (y c) (1- rows)))
1608 |       (setf (cursor term) c))))
1609 | 


--------------------------------------------------------------------------------