1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2% 3% File: TERMIO.SL 4% Description: Terminal i-o with protocol and pagemode 5% Author: Herbert Melenk 6% Created: 4-April-90 7% Modified: 8% Package: 9% Status: Open Source: BSD License 10% 11% Redistribution and use in source and binary forms, with or without 12% modification, are permitted provided that the following conditions are met: 13% 14% * Redistributions of source code must retain the relevant copyright 15% notice, this list of conditions and the following disclaimer. 16% * Redistributions in binary form must reproduce the above copyright 17% notice, this list of conditions and the following disclaimer in the 18% documentation and/or other materials provided with the distribution. 19% 20% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 22% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 23% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR 24% CONTRIBUTORS 25% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 26% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 27% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 28% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 29% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 30% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31% POSSIBILITY OF SUCH DAMAGE. 32% 33%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 34 35(compiletime (load inum fast-vector fast-int)) 36 37(compiletime (flag '(reset-terminal-page sync-terminal 38 char-to-protfile beiss-ab) 39 'internalfunction)) 40 41 42(compiletime (progn 43 (define-constant ESC 16#01B) 44 % cursor 45 (define-constant BACKSPACE 16#008) 46 (define-constant DELETE 16#153) 47 (define-constant INSERT 16#152) 48 (define-constant HOME 16#147) 49 (define-constant END 16#14F) 50 (define-constant UP 16#148) 51 (define-constant DOWN 16#150) 52 (define-constant RIGHT 16#14D) 53 (define-constant LEFT 16#14B) 54 % page 55 (define-constant PAGEUP 16#149) % I 56 (define-constant PAGEDOWN 16#151) % Q 57 % tabulator 58 (define-constant TABLEFT 16#10f) 59 (define-constant TABRIGHT 16#009) 60)) 61 62 63(fluid '(oldterminalinputhandler oldterminaloutputhandler protfile 64 morechars* terminaldir linebuffer* 65 pagelength* bufferfile!* *page **windows)) 66 67(flag '(page) 'switch) 68 69(setq pagelength* 23) 70 71(when (null oldterminalinputhandler) 72 (setq oldterminalinputhandler (wgetv readfunction 0)) 73 (setq oldterminaloutputhandler (wgetv writefunction 1)) 74) 75 76(de hard-readch() 77 % hard-wired terminal input 78 (prog(c) 79 (&time-control nil) 80 (setq c (int_7)) 81 (&time-control t) 82 (return (wand c 16#ff)))) 83 84(de hard-princ(c) 85 (&time-control nil) 86 (int_2 (wand c 16#ff)) 87 (&time-control t)) 88 89 90(de protfile (u) 91 (when (weq **windows 1) 92 (stderror "use dribble file from Edit menu instead")) 93 (when protfile (close protfile)) 94 (setq protfile nil) 95 (cond ((or (equal u "") (null u)(eq u T)) nil) 96 ((stringp u) (setq protfile (open u 'OUTPUT)) u) 97 ((idp u)(setq protfile (open (id2string u) 'OUTPUT)) u) 98 (t (stderror "protfile must be called with string or id")))) 99 100(de newterminalinputhandler (u) 101 (prog(c) 102 (when (not *page) 103 (return 104 (idapply oldterminalinputhandler (list u)))) 105 106 % fresh buffer necessary 107 (when (wgreaterp (wgetv nextposition u) 108 (wgetv bufferlength u)) 109 (channelwritestring promptout* 110 (if (stringp promptstring*) promptstring* ">")) 111 (flushbuffer promptout*) 112 (when (weq promptout* stdout*) 113 (setf (wgetv lineposition promptout*) 0)) 114 (setf (wgetv bufferlength u) 115 (line-from-terminal u)) 116 (setf (wgetv nextposition u) 0) ) 117 118 % pick character from buffer 119 (setq c (strbyt (strinf(igetv iobuffer u)) 120 (wgetv nextposition u))) 121 (setf (wgetv nextposition u) 122 (iadd1 (wgetv nextposition u))) 123 124 % page control and protocol generation 125 (reset-terminal-page) 126 (when protfile (when (weq terminaldir 1) 127 (channelterpri protfile) 128 (setq terminaldir -1)) 129 (char-to-protfile c)) 130 (return c))) 131 132(de newterminaloutputhandler (ch u) 133 (prog(ll p) 134 (when (not *page) (go ready)) 135 (setq ll (isub1 (wgetv maxline ch))) 136 (setq p (wgetv lineposition ch)) 137 (when (and (wgreaterp p 0) (izerop (iremainder p ll))) 138 (setf (wgetv pageposition ch) (iadd1 (wgetv pageposition ch))) 139 (when (and bufferfile!* (eq ch 1)) 140 (channelterpri bufferfile!*))) 141 (when (and pagelength* (intp pagelength*) 142 (wgreaterp (wgetv pageposition ch) pagelength*)) 143 (idapply oldterminaloutputhandler (list ch (char eol))) 144 (mapc '(- - M !o !r !e - -) 145 (function hard-princ)) 146 (reset-terminal-page) 147 (sync-terminal)) 148 (when (and bufferfile!* (eq ch 1)) 149 (channelwritechar bufferfile!* u)) 150 (when (and protfile (eq ch 1)) 151 (when (weq terminaldir -1) 152 (channelterpri protfile) 153 (setq terminaldir 1)) 154 (char-to-protfile u)) 155 ready 156 (return (idapply oldterminaloutputhandler (list ch u))))) 157 158(de char-to-protfile(u) 159 (cond ((weq u (char (cntrl m)))) % ignore 160 ((weq u (char (cntrl j))) (channelterpri protfile)) 161 (t (channelwritechar protfile u)))) 162 163(de reset-terminal-page() 164 (setf (wgetv lineposition 1) 0) 165 (setf (wgetv pageposition 1) 0)) 166 167(de sync-terminal() 168 (let ((c (hard-readch))) 169 (if (eq c (char (cntrl C))) 170 (stderror "break from terminal ") 171 % (setq morechars* (append morechars* (list c))) 172 ))) 173 174(de pagelength(n) 175 (prog(m) 176 (setq m pagelength*) 177 (if (not (intp n)) (stderror "*** illegal parameter for pagelength") 178 (setq pagelength* n)) 179 (return m))) 180 181(de pageon(i) 182 (when (and (weq i 1) (weq **windows 1)) 183 (stderror "use edit menue entry instead of switch PAGE")) 184 (setf (wgetv readfunction 0) 'newterminalinputhandler) 185 (setf (wgetv pageposition 1) 0) 186 (setf (wgetv writefunction 1)'newterminaloutputhandler) 187) 188 189(pageon 0) 190 191(put 'page 'simpfg '((nil nil) 192 (t (pageon 1)))) 193 194(de pagebuffer(n) 195 (when (null (getd 'mf-open)) (load1 'memio)) 196 (when (null bufferfile!*) (setq bufferfile!* (mf-open "buffer" 'output))) 197 (mf-setmax bufferfile!* n)) 198 199(pagebuffer 200) 200 201(compiletime 202 203(ds page-over(u v n) 204 % move n elements from u to v as long as possible 205 (ifor (from i 1 n 1) 206 (do 207 (when u 208 (setq v (cons (car u) v)) 209 (setq u (cdr u)) )))) 210) 211 212(de wposmin(n m) 213 % positive minimum from n and m 214 (setq n (if (wgreaterp n m) m n)) 215 (if (wlessp n 0) 0 n)) 216 217 218(de show-page() 219 (let*((bf bufferfile!*) 220 (bufferfile!* nil) 221 (pl pagelength*) 222 (pagelength* nil) 223 fwd bwd 224 x y n) 225 (prog() 226 (reset-terminal-page) 227 (setq bwd (reversip (mf2list bf))) 228 (page-over bwd fwd pl) 229 show (setq y (print-page fwd bwd pl)) 230 cmd (setq x (char-from-terminal)) 231 (cond 232 ((eq x HOME) 233 (setq fwd (append (reverse bwd) fwd)) 234 (setq bwd nil) 235 (go show)) 236 ((eq x UP) 237 (page-over bwd fwd 5) 238 (go show)) 239 ((eq x DOWN) 240 (page-over fwd bwd 241 (wposmin 5 (wdifference (length fwd) pl))) 242 (go show)) 243 ((eq x PAGEUP) 244 (page-over bwd fwd pl) 245 (go show)) 246 ((eq x PAGEDOWN) 247 (page-over fwd bwd 248 (wposmin pl (wdifference (length fwd) pl))) 249 (go show)) 250 ) 251 (reset-terminal-page) 252 (return x) 253 ))) 254 255(de char-from-terminal() 256 (prog (x y) 257 (setq x (hard-readch)) 258 (when (not (eq x 0)) 259 (when (wgreaterp x 127) (setq x 1)) 260 (return x)) 261 (setq y (hard-readch)) 262 (return (wplus2 16#100 y)))) 263 264(de print-page(fwd bwd n) 265 (terpri) 266 (hard-line (when (null bwd) '(T O P))) 267 (terpri) 268 (ifor (from i 1 n 1) 269 (do 270 (when fwd 271 (prin2 (car fwd)) 272 (setq fwd (cdr fwd))))) 273 (hard-line (when (null fwd) '(B O T T O M))) ) 274 275(de hard-line(text) 276 (ifor (from i 1 35 1) (do (hard-princ (char -)))) 277 (mapc text (function hard-princ)) 278 (ifor (from i 1 35 1) (do (hard-princ (char -)))) 279) 280 281(flag '(pagelength protfile pagebuffer) 'opfn) 282 283(compiletime 284 (ds linebyte(x) (strbyt (strinf ln) x)) 285) 286 287(de line-from-terminal(u) 288 (prog (ln c n xn mx ins lb lbr ol lth) 289 (setq lb linebuffer*) 290 (setq ins t) 291 (setq ln (igetv iobuffer u)) 292 (setq mx (wgetv maxbuffer u)) 293 (setq n -1 xn -1) 294 next (when (not (wgreaterp mx n)) (go ready1)) 295 (setq c (if morechars* (pop morechars*) (char-from-terminal))) 296 (when (or (eq c PAGEUP) 297 ) 298 (setq c (show-page)) 299 (terpri) 300 (ifor (from i 0 n 1) 301 (do 302 (hard-princ 303 (strbyt (strinf ln) i)))) 304 ) 305 (when (eq c UP) % fetch old line 306 (when (null lb) (go next)) 307 (clear-line n xn) 308 (setq ol (pop lb)) 309 (push ol lbr) 310 (go copyline)) 311 312 (when (eq c DOWN) % fetch old line 313 (clear-line n xn) (setq n (setq xn -1)) 314 (when (null lbr) (go next)) 315 (setq ol (pop lbr)) 316 (push ol lb) 317 (go copyline)) 318 319 ret 320 (cond 321 ((eq c ESC) 322 (clear-line n xn) (setq n (setq xn -1)) 323 (go next)) 324 325 ((eq c HOME) 326 (ifor (from i (isub1 n) -1 -1) 327 (do (progn (setq n i) (hard-princ BACKSPACE))))) 328 329 ((eq c END) 330 (ifor (from i (iadd1 n) xn 1) 331 (do (progn (setq n i) (hard-princ (linebyte i)) )))) 332 333 ((eq c BACKSPACE) 334 (when (wgeq n 0) 335 (setf n (isub1 n)) 336 (hard-princ BACKSPACE) 337 (go delete))) 338 339 ((eq c LEFT) 340 (when (wgreaterp n 0) 341 (hard-princ BACKSPACE) 342 (setq n (isub1 n)))) 343 344 ((eq c RIGHT) 345 (when (wlessp n xn) 346 (setq n (iadd1 n)) 347 (hard-princ (strbyt (strinf ln) n)) 348 )) 349 350 ((eq c DELETE) % skip one char 351 (go delete)) 352 353 ((eq c INSERT) % switch inser mode 354 (setq ins (not ins)) 355 (go next)) 356 357 ((eq c (char (cntrl C))) 358 (setf (wgetv bufferlength u) -1) 359 (stderror "break from terminal ")) 360 ((and (or (eq c (char (cntrl m)))(eq c (char (cntrl D)))) 361 (wlessp n xn)) 362 (hard-princ c) 363 (setq xn (iadd1 xn)) 364 (setf (linebyte xn) c) 365 (go ready) 366 ) % don't destroy line 367 368 (t 369 (when (and ins (wlessp n xn)) % insert ? 370 (hard-princ (char BLANK)) 371 (ifor (from i (iadd1 n) xn 1) 372 (do (hard-princ (linebyte i)))) 373 (ifor (from i xn n -1) 374 (do (progn 375 (setf (linebyte (iadd1 i)) (linebyte i)) 376 (hard-princ BACKSPACE)))) 377 (setq xn (iadd1 xn)) 378 ) 379 (setq n (iadd1 n)) 380 (setf (strbyt (strinf ln) n) c) 381 (hard-princ c) 382 )) 383 (when (wgreaterp n xn)(setq xn n)) 384 385 (when (or (eq c (char (cntrl m)))(eq c (char (cntrl D)))) 386 (go ready)) 387 (go next) 388 389 delete 390 (when (wgeq n xn) (go next)) 391 (ifor (from i (iadd1 (iadd1 n)) xn 1) 392 (do (progn 393 (hard-princ (linebyte i)) 394 (setf (linebyte (isub1 i))(linebyte i)) 395 ))) 396 (hard-princ (char BLANK)) 397 (hard-princ BACKSPACE) 398 (ifor (from i xn (iadd1 (iadd1 n)) -1) 399 (do (hard-princ BACKSPACE))) 400 (setq xn (isub1 xn)) 401 (go next) 402 403 copyline 404 (setq lth (strlen (strinf ol))) 405 (ifor (from i 0 lth 1) 406 (do (progn 407 (setq c (strbyt (strinf ol) i)) 408 (hard-princ c) 409 (setf (strbyt (strinf ln) i) c)))) 410 (setq xn lth) 411 (setq n xn) 412 (go next) 413 414 ready (setq n (iadd1 n)) 415 (hard-princ (char eol)) 416 (ifor (from i 1 80 1) 417 (do (hard-princ BACKSPACE))) 418 419 (setf (strbyt (strinf ln) xn) (char eol)) 420% ready1(setq oldlinefill* xn) 421% (ifor (from i 0 xn 1) 422% (do (setf (strbyt(strinf oldline*) i) 423% (strbyt (strinf ln) i)))) 424 ready1 425 (push (subseq ln 0 xn) linebuffer*) 426 (beiss-ab linebuffer* 20) 427 (return xn))) 428 429(de beiss-ab(l n) 430 (cond ((null l) l) 431 ((wleq n 0) (setf (cdr l) nil)) 432 (t (beiss-ab (cdr l)(isub1 n))) )) 433 434 (de clear-line(n xn) 435 (ifor (from i n 0 -1) 436 (do (hard-princ BACKSPACE))) 437 (ifor (from i 0 xn 1) 438 (do (hard-princ (char blank)))) 439 (ifor (from i 0 xn 1) 440 (do (hard-princ BACKSPACE)))) 441 442 443