335 lines
12 KiB
Scheme
335 lines
12 KiB
Scheme
#| -*-Scheme-*-
|
||
|
||
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
|
||
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
|
||
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
|
||
2017, 2018, 2019, 2020 Massachusetts Institute of Technology
|
||
|
||
This file is part of MIT/GNU Scheme.
|
||
|
||
MIT/GNU Scheme is free software; you can redistribute it and/or modify
|
||
it under the terms of the GNU General Public License as published by
|
||
the Free Software Foundation; either version 2 of the License, or (at
|
||
your option) any later version.
|
||
|
||
MIT/GNU Scheme is distributed in the hope that it will be useful, but
|
||
WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
General Public License for more details.
|
||
|
||
You should have received a copy of the GNU General Public License
|
||
along with MIT/GNU Scheme; if not, write to the Free Software
|
||
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
|
||
USA.
|
||
|
||
|#
|
||
|
||
;;;; Termcap(3) Interface
|
||
|
||
|
||
|
||
(define-primitives
|
||
(termcap-initialize 1)
|
||
(termcap-get-number 1)
|
||
(termcap-get-flag 1)
|
||
(termcap-get-string 1)
|
||
(termcap-param-string 5)
|
||
(termcap-goto-string 5)
|
||
(termcap-pad-string 4))
|
||
|
||
(define-structure (termcap-description
|
||
(constructor %make-termcap-description)
|
||
(conc-name false))
|
||
(terminal-type-name false read-only true)
|
||
|
||
(delete-is-insert-mode? false read-only true)
|
||
(enter/exit-standout-mode-same? false read-only true)
|
||
(insert/delete-char-ok? false read-only true)
|
||
(insert/delete-line-ok? false read-only true)
|
||
(scroll-region-ok? false read-only true)
|
||
|
||
(tf-automatic-wrap false read-only true)
|
||
(tf-cursor-backwards-wrap false read-only true)
|
||
(tf-generic false read-only true)
|
||
(tf-hardcopy false read-only true)
|
||
(tf-hazeltine false read-only true)
|
||
(tf-insert-mode-motion false read-only true)
|
||
(tf-lose-wrap false read-only true)
|
||
(tf-magic-wrap false read-only true)
|
||
(tf-memory-above-screen false read-only true)
|
||
(tf-memory-below-screen false read-only true)
|
||
(tf-meta-key false read-only true)
|
||
(tf-must-write-spaces false read-only true)
|
||
(tf-newline-doesnt-scroll false read-only true)
|
||
(tf-overstrike false read-only true)
|
||
(tf-overstrike-space-erase false read-only true)
|
||
(tf-overwrite-preserves-standout false read-only true)
|
||
(tf-standout-mode-motion false read-only true)
|
||
(tf-teleray false read-only true)
|
||
(tf-underscore false read-only true)
|
||
|
||
(tn-memory-lines false read-only true)
|
||
(tn-minimum-padding-speed false read-only true)
|
||
(tn-standout-marker-width false read-only true)
|
||
(tn-x-size false read-only false)
|
||
(tn-y-size false read-only false)
|
||
|
||
(ts-audible-bell false read-only true)
|
||
(ts-clear-line false read-only true)
|
||
(ts-clear-multi-char false read-only true)
|
||
(ts-clear-screen false read-only true)
|
||
(ts-clear-to-bottom false read-only true)
|
||
(ts-cursor-down false read-only true)
|
||
(ts-cursor-down-multi false read-only true)
|
||
(ts-cursor-left false read-only true)
|
||
(ts-cursor-left-multi false read-only true)
|
||
(ts-cursor-line-start false read-only true)
|
||
(ts-cursor-lower-left false read-only true)
|
||
(ts-cursor-move false read-only true)
|
||
(ts-cursor-move-x false read-only true)
|
||
(ts-cursor-right false read-only true)
|
||
(ts-cursor-right-multi false read-only true)
|
||
(ts-cursor-up false read-only true)
|
||
(ts-cursor-up-multi false read-only true)
|
||
(ts-cursor-upper-left false read-only true)
|
||
(ts-delete-char false read-only true)
|
||
(ts-delete-line false read-only true)
|
||
(ts-delete-multi-char false read-only true)
|
||
(ts-delete-multi-line false read-only true)
|
||
(ts-enhance-cursor false read-only true)
|
||
(ts-enter-delete-mode false read-only true)
|
||
(ts-enter-insert-mode false read-only true)
|
||
(ts-enter-standout-mode false read-only true)
|
||
(ts-enter-termcap-mode false read-only true)
|
||
(ts-enter-keypad-mode false read-only true)
|
||
(ts-exit-delete-mode false read-only true)
|
||
(ts-exit-insert-mode false read-only true)
|
||
(ts-exit-standout-mode false read-only true)
|
||
(ts-exit-termcap-mode false read-only true)
|
||
(ts-exit-keypad-mode false read-only true)
|
||
(ts-forward-scroll false read-only true)
|
||
(ts-forward-scroll-multi false read-only true)
|
||
(ts-insert-char false read-only true)
|
||
(ts-insert-line false read-only true)
|
||
(ts-insert-multi-char false read-only true)
|
||
(ts-insert-multi-line false read-only true)
|
||
(ts-invisible-cursor false read-only true)
|
||
(ts-normal-cursor false read-only true)
|
||
(ts-pad-char false read-only true)
|
||
(ts-pad-inserted-char false read-only true)
|
||
(ts-reverse-scroll false read-only true)
|
||
(ts-reverse-scroll-multi false read-only true)
|
||
(ts-set-scroll-region false read-only true)
|
||
(ts-set-scroll-region-1 false read-only true)
|
||
(ts-set-window false read-only true)
|
||
(ts-visible-bell false read-only true)
|
||
|
||
;; keys is an alist mapping key names (symbols) to strings or #F
|
||
(termcap-description-keys false read-only true) )
|
||
|
||
(define (make-termcap-description terminal-type-name)
|
||
(if (string-ci=? terminal-type-name "ansi.sys")
|
||
(let ((x-size (output-port/x-size (console-i/o-port)))
|
||
(y-size (output-port/y-size (console-i/o-port))))
|
||
(make-ansi-terminal-description x-size y-size))
|
||
(and (implemented-primitive-procedure?
|
||
(ucode-primitive termcap-initialize 1))
|
||
(termcap-initialize terminal-type-name)
|
||
(let ((supdup? (string=? terminal-type-name "supdup"))
|
||
(tn-standout-marker-width (termcap-get-number "sg"))
|
||
(ts-cursor-down
|
||
(or (termcap-get-string "do") (termcap-get-string "nl")))
|
||
(ts-delete-char (termcap-get-string "dc"))
|
||
(ts-delete-line (termcap-get-string "dl"))
|
||
(ts-delete-multi-char (termcap-get-string "DC"))
|
||
(ts-delete-multi-line (termcap-get-string "DL"))
|
||
(ts-enter-delete-mode (termcap-get-string "dm"))
|
||
(ts-enter-insert-mode (termcap-get-string "im"))
|
||
(ts-enter-standout-mode (termcap-get-string "so"))
|
||
(ts-exit-standout-mode (termcap-get-string "se"))
|
||
(ts-forward-scroll (termcap-get-string "sf"))
|
||
(ts-forward-scroll-multi (termcap-get-string "SF"))
|
||
(ts-insert-char (termcap-get-string "ic"))
|
||
(ts-insert-line (termcap-get-string "al"))
|
||
(ts-insert-multi-char (termcap-get-string "IC"))
|
||
(ts-insert-multi-line (termcap-get-string "AL"))
|
||
(ts-pad-inserted-char (termcap-get-string "ip"))
|
||
(ts-reverse-scroll (termcap-get-string "sr"))
|
||
(ts-reverse-scroll-multi (termcap-get-string "SR"))
|
||
(ts-set-scroll-region (termcap-get-string "cs"))
|
||
(ts-set-scroll-region-1 (termcap-get-string "cS"))
|
||
(ts-set-window (termcap-get-string "wi")))
|
||
(if (not ts-forward-scroll)
|
||
(set! ts-forward-scroll ts-cursor-down))
|
||
(if (not ts-enter-standout-mode)
|
||
(begin
|
||
(set! tn-standout-marker-width (termcap-get-number "ug"))
|
||
(set! ts-enter-standout-mode (termcap-get-string "us"))
|
||
(set! ts-exit-standout-mode (termcap-get-string "ue"))))
|
||
(%make-termcap-description
|
||
terminal-type-name
|
||
|
||
;; delete-is-insert-mode?
|
||
(and ts-enter-delete-mode
|
||
ts-enter-insert-mode
|
||
(string=? ts-enter-delete-mode ts-enter-insert-mode))
|
||
;; enter/exit-standout-mode-same?
|
||
(and ts-enter-standout-mode
|
||
ts-exit-standout-mode
|
||
(string=? ts-enter-standout-mode ts-exit-standout-mode))
|
||
;; insert/delete-char-ok?
|
||
(and (or ts-insert-char ts-insert-multi-char
|
||
ts-enter-insert-mode ts-pad-inserted-char)
|
||
(or ts-delete-char ts-delete-multi-char))
|
||
;; insert/delete-line-ok?
|
||
(or (and (or ts-insert-line ts-insert-multi-line)
|
||
(or ts-delete-line ts-delete-multi-line))
|
||
(and (or ts-set-scroll-region
|
||
ts-set-scroll-region-1
|
||
ts-set-window)
|
||
(or ts-forward-scroll ts-forward-scroll-multi)
|
||
(or ts-reverse-scroll ts-reverse-scroll-multi)))
|
||
;; scroll-region-ok?
|
||
(or ts-set-scroll-region ts-set-scroll-region-1 ts-set-window)
|
||
|
||
(termcap-get-flag "am") ;tf-automatic-wrap
|
||
(termcap-get-flag "bw") ;tf-cursor-backwards-wrap
|
||
(termcap-get-flag "gn") ;tf-generic
|
||
(termcap-get-flag "hc") ;tf-hardcopy
|
||
(termcap-get-flag "hz") ;tf-hazeltine
|
||
(termcap-get-flag "mi") ;tf-insert-mode-motion
|
||
supdup? ;tf-lose-wrap
|
||
(termcap-get-flag "xn") ;tf-magic-wrap
|
||
(termcap-get-flag "da") ;tf-memory-above-screen
|
||
(or (termcap-get-flag "db") ;tf-memory-below-screen
|
||
supdup?)
|
||
(or (termcap-get-flag "km") ;tf-meta-key
|
||
(termcap-get-flag "MT"))
|
||
(termcap-get-flag "in") ;tf-must-write-spaces
|
||
(termcap-get-flag "ns") ;tf-newline-doesnt-scroll
|
||
(termcap-get-flag "os") ;tf-overstrike
|
||
(termcap-get-flag "eo") ;tf-overstrike-space-erase
|
||
(termcap-get-flag "xs") ;tf-overwrite-preserves-standout
|
||
(termcap-get-flag "ms") ;tf-standout-mode-motion
|
||
(termcap-get-flag "xt") ;tf-teleray
|
||
(termcap-get-flag "ul") ;tf-underscore
|
||
|
||
(termcap-get-number "lm") ;tn-memory-lines
|
||
(termcap-get-number "pb") ;tn-minimum-padding-speed
|
||
tn-standout-marker-width
|
||
(termcap-get-number "co") ;tn-x-size
|
||
(termcap-get-number "li") ;tn-y-size
|
||
|
||
(or (termcap-get-string "bl") ;ts-audible-bell
|
||
"\007")
|
||
(termcap-get-string "ce") ;ts-clear-line
|
||
(termcap-get-string "ec") ;ts-clear-multi-char
|
||
(termcap-get-string "cl") ;ts-clear-screen
|
||
(termcap-get-string "cd") ;ts-clear-to-bottom
|
||
ts-cursor-down
|
||
(termcap-get-string "DO") ;ts-cursor-down-multi
|
||
(if (termcap-get-flag "bs") ;ts-cursor-left
|
||
"\010"
|
||
(or (termcap-get-string "le")
|
||
(termcap-get-string "bc")))
|
||
(termcap-get-string "LE") ;ts-cursor-left-multi
|
||
(termcap-get-string "cr") ;ts-cursor-line-start
|
||
(termcap-get-string "ll") ;ts-cursor-lower-left
|
||
(termcap-get-string "cm") ;ts-cursor-move
|
||
(termcap-get-string "ch") ;ts-cursor-move-x
|
||
(termcap-get-string "nd") ;ts-cursor-right
|
||
(termcap-get-string "RI") ;ts-cursor-right-multi
|
||
(termcap-get-string "up") ;ts-cursor-up
|
||
(termcap-get-string "UP") ;ts-cursor-up-multi
|
||
(termcap-get-string "ho") ;ts-cursor-upper-left
|
||
ts-delete-char
|
||
ts-delete-line
|
||
ts-delete-multi-char
|
||
ts-delete-multi-line
|
||
(termcap-get-string "vs") ;ts-enhance-cursor
|
||
ts-enter-delete-mode
|
||
ts-enter-insert-mode
|
||
ts-enter-standout-mode
|
||
(termcap-get-string "ti") ;ts-enter-termcap-mode
|
||
(termcap-get-string "ks") ;ts-enter-keypad-mode
|
||
(termcap-get-string "ed") ;ts-exit-delete-mode
|
||
(termcap-get-string "ei") ;ts-exit-insert-mode
|
||
ts-exit-standout-mode
|
||
(termcap-get-string "te") ;ts-exit-termcap-mode
|
||
(termcap-get-string "ke") ;ts-exit-keypad-mode
|
||
ts-forward-scroll
|
||
ts-forward-scroll-multi
|
||
ts-insert-char
|
||
ts-insert-line
|
||
ts-insert-multi-char
|
||
ts-insert-multi-line
|
||
(termcap-get-string "vi") ;ts-invisible-cursor
|
||
(termcap-get-string "ve") ;ts-normal-cursor
|
||
(termcap-get-string "pc") ;ts-pad-char
|
||
ts-pad-inserted-char
|
||
ts-reverse-scroll
|
||
ts-reverse-scroll-multi
|
||
ts-set-scroll-region
|
||
ts-set-scroll-region-1
|
||
ts-set-window
|
||
(termcap-get-string "vb") ;ts-visible-bell
|
||
|
||
; ts-keys
|
||
(append-map (lambda (string.name)
|
||
(let* ((string (car string.name))
|
||
(keystr (termcap-get-string string)))
|
||
(if keystr
|
||
(list (cons (cdr string.name) keystr))
|
||
'() )))
|
||
termcap-key-codes))))))
|
||
|
||
|
||
(define termcap-key-codes
|
||
`(("ku" . up) ;arrow keys
|
||
("kd" . down) ; " "
|
||
("kl" . left) ; " "
|
||
("kr" . right) ; " "
|
||
("kb" . backspace)
|
||
("ka" . clear-all-tabs) ; clear-all-tabs key
|
||
("kC" . clear) ; clear screen or erase
|
||
("kt" . clear-tab) ; clear-tab
|
||
("kD" . delete-char) ; delete character
|
||
("kL" . delete-line) ; delete line
|
||
("kE" . clear-eol) ; clear-to-end-of-line key
|
||
("kS" . clear-eos) ; clear-to-end-of-screen key
|
||
("k0" . f0)
|
||
("k1" . f1)
|
||
("k2" . f2)
|
||
("k3" . f3)
|
||
("k4" . f4)
|
||
("k5" . f5)
|
||
("k6" . f6)
|
||
("k7" . f7)
|
||
("k8" . f8)
|
||
("k9" . f9)
|
||
("ka" . f10)
|
||
("F1" . f11)
|
||
("F2" . f12)
|
||
("F3" . f13)
|
||
("F4" . f14)
|
||
("F5" . f15)
|
||
("F6" . f16)
|
||
("F7" . f17)
|
||
("F8" . f18)
|
||
("F9" . f19)
|
||
("FA" . f20)
|
||
("FB" . f21)
|
||
("FC" . f22)
|
||
("FD" . f23)
|
||
("FE" . f24)
|
||
("kh" . home) ; home key
|
||
("kI" . insert-char) ; insert-char or enter-insert-mode
|
||
("kA" . insert-line) ; insert-line key
|
||
("kH" . home-down)
|
||
("kN" . next-page) ; next-page key
|
||
("kP" . previous-page) ; previous-page key
|
||
("kF" . scroll-forward) ; scroll-forward / scroll-down
|
||
("kR" . scroll-backward) ; scroll-backward / scroll-up
|
||
("kT" . set-tab)
|
||
))
|