--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/termcap.scm,v 1.1 1990/11/02 04:16:24 cph Rel $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Termcap(3) Interface
+
+(declare (usual-integrations))
+
+(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))
+\f
+(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 true)
+ (tn-y-size false read-only true)
+
+ (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-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-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))
+\f
+(define (make-termcap-description terminal-type-name)
+ (and (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 "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
+ 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
+ ))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tterm.scm,v 1.1 1990/11/02 04:16:38 cph Exp $
+
+Copyright (c) 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Termcap(3) Screen Implementation
+
+(declare (usual-integrations))
+
+(define-primitives
+ (baud-rate->index 1)
+ (tty-get-interrupt-enables 0)
+ (tty-set-interrupt-enables 1))
+
+(define (output-port/baud-rate port)
+ (let ((channel (output-port/channel port)))
+ (and channel
+ (channel-type=terminal? channel)
+ (terminal-output-baud-rate channel))))
+
+(define (output-port/buffered-chars port)
+ (let ((operation (output-port/operation port 'BUFFERED-CHARS)))
+ (if operation
+ (operation port)
+ 0)))
+\f
+(define (console-available?)
+ (let ((description (console-termcap-description)))
+ (and (termcap-description? description)
+ (sufficiently-powerful? description)
+ (no-undesirable-characteristics? description))))
+
+(define (make-console-screen)
+ (let ((description (console-termcap-description)))
+ (cond ((not (output-port/baud-rate console-output-port))
+ (error "standard output not a terminal"))
+ ((not description)
+ (error "terminal type not set"))
+ ((not (termcap-description? description))
+ (error "unknown terminal type" description))
+ ((not (sufficiently-powerful? description))
+ (error "terminal type not powerful enough"
+ (terminal-type-name description)))
+ ((not (no-undesirable-characteristics? description))
+ (error "terminal type has undesirable characteristics"
+ (terminal-type-name description))))
+ (make-screen (let ((baud-rate (output-port/baud-rate console-output-port)))
+ (let ((baud-rate-index (baud-rate->index baud-rate)))
+ (make-terminal-state
+ description
+ baud-rate-index
+ baud-rate
+ (fix:1+ (fix:quotient baud-rate 2400)))))
+ console-beep
+ console-clear-line!
+ console-clear-rectangle!
+ console-clear-screen!
+ console-discard!
+ console-enter!
+ console-exit!
+ console-flush!
+ console-modeline-event!
+ console-preempt-update?
+ console-scroll-lines-down!
+ console-scroll-lines-up!
+ console-wrap-update!
+ console-write-char!
+ console-write-cursor!
+ console-write-substring!
+ (tn-x-size description)
+ (tn-y-size description))))
+
+(define (console-termcap-description)
+ (if (eq? console-description 'UNKNOWN)
+ (set! console-description
+ (let ((term ((ucode-primitive get-environment-variable 1) "TERM")))
+ (and term
+ (or (and (output-port/baud-rate console-output-port)
+ (make-termcap-description term))
+ term)))))
+ console-description)
+
+(define (sufficiently-powerful? description)
+ (and (let ((x-size (tn-x-size description)))
+ (and x-size
+ (> x-size 0)))
+ (let ((y-size (tn-y-size description)))
+ (and y-size
+ (> y-size 0)))
+ (ts-cursor-move description)))
+
+(define (no-undesirable-characteristics? description)
+ (not (or (tf-hazeltine description)
+ (tf-teleray description)
+ (tf-underscore description))))
+\f
+(define (make-console-input-port screen)
+ screen ; ignored
+ console-input-port)
+
+(define (signal-interrupt! interrupt-enables)
+ interrupt-enables ; ignored
+ ;; (editor-beep) ; kbd beeps by itself
+ (temporary-message "Quit")
+ (^G-signal))
+
+(define (with-console-interrupts-enabled thunk)
+ (with-console-interrupt-state 2 thunk))
+
+(define (with-console-interrupts-disabled thunk)
+ (with-console-interrupt-state 0 thunk))
+
+(define (with-console-interrupt-state state thunk)
+ (let ((outside)
+ (inside state))
+ (dynamic-wind (lambda ()
+ (set! outside (tty-get-interrupt-enables))
+ (tty-set-interrupt-enables inside))
+ thunk
+ (lambda ()
+ (set! inside (tty-get-interrupt-enables))
+ (tty-set-interrupt-enables outside)))))
+
+(define console-display-type)
+(define console-description)
+
+(define (initialize-package!)
+ (set! console-display-type
+ (make-display-type 'CONSOLE
+ false
+ console-available?
+ make-console-screen
+ make-console-input-port
+ with-console-grabbed
+ with-console-interrupts-enabled
+ with-console-interrupts-disabled))
+ (set! console-description 'UNKNOWN)
+ unspecific)
+\f
+(define (with-console-grabbed receiver)
+ (bind-console-state false
+ (lambda (get-outside-state)
+ (terminal-operation terminal-raw-input
+ (input-port/channel console-input-port))
+ (terminal-operation terminal-raw-output
+ (output-port/channel console-output-port))
+ (set! hook/^g-interrupt signal-interrupt!)
+ (tty-set-interrupt-enables 2)
+ (receiver
+ (lambda (thunk)
+ (bind-console-state (get-outside-state)
+ (lambda (get-inside-state)
+ get-inside-state
+ (thunk))))))))
+
+(define (bind-console-state state receiver)
+ (let ((outside-state)
+ (inside-state state))
+ (dynamic-wind (lambda ()
+ (set! outside-state (console-state))
+ (if inside-state
+ (set-console-state! inside-state))
+ (set! inside-state false)
+ unspecific)
+ (lambda ()
+ (receiver (lambda () outside-state)))
+ (lambda ()
+ (set! inside-state (console-state))
+ (set-console-state! outside-state)
+ (set! outside-state false)
+ unspecific))))
+
+(define (console-state)
+ (vector (channel-state (input-port/channel console-input-port))
+ (channel-state (output-port/channel console-output-port))
+ hook/^g-interrupt
+ (tty-get-interrupt-enables)))
+
+(define (set-console-state! state)
+ (set-channel-state! (input-port/channel console-input-port)
+ (vector-ref state 0))
+ (set-channel-state! (output-port/channel console-output-port)
+ (vector-ref state 1))
+ (set! hook/^g-interrupt (vector-ref state 2))
+ (tty-set-interrupt-enables (vector-ref state 3)))
+
+(define (channel-state channel)
+ (and channel
+ (channel-type=terminal? channel)
+ (terminal-get-state channel)))
+
+(define (set-channel-state! channel state)
+ (if (and channel
+ (channel-type=terminal? channel)
+ state)
+ (terminal-set-state channel state)))
+
+(define (terminal-operation operation channel)
+ (if (and channel
+ (channel-type=terminal? channel))
+ (operation channel)))
+\f
+;;;; Terminal State
+
+(define-structure (terminal-state
+ (constructor make-terminal-state
+ (description
+ baud-rate-index
+ baud-rate
+ preemption-modulus))
+ (conc-name terminal-state/))
+ (description false read-only true)
+ (baud-rate-index false read-only true)
+ (baud-rate false read-only true)
+ (preemption-modulus false read-only true)
+ (cursor-x false)
+ (cursor-y false)
+ (standout-mode? false)
+ (insert-mode? false)
+ (delete-mode? false)
+ (scroll-region false))
+
+(define-integrable (screen-description screen)
+ (terminal-state/description (screen-state screen)))
+
+(define-integrable (screen-baud-rate-index screen)
+ (terminal-state/baud-rate-index (screen-state screen)))
+
+(define-integrable (screen-baud-rate screen)
+ (terminal-state/baud-rate (screen-state screen)))
+
+(define-integrable (screen-preemption-modulus screen)
+ (terminal-state/preemption-modulus (screen-state screen)))
+
+(define-integrable (screen-cursor-x screen)
+ (terminal-state/cursor-x (screen-state screen)))
+
+(define-integrable (set-screen-cursor-x! screen cursor-x)
+ (set-terminal-state/cursor-x! (screen-state screen) cursor-x))
+
+(define-integrable (screen-cursor-y screen)
+ (terminal-state/cursor-y (screen-state screen)))
+
+(define-integrable (set-screen-cursor-y! screen cursor-y)
+ (set-terminal-state/cursor-y! (screen-state screen) cursor-y))
+
+(define-integrable (screen-standout-mode? screen)
+ (terminal-state/standout-mode? (screen-state screen)))
+
+(define-integrable (set-screen-standout-mode?! screen standout-mode?)
+ (set-terminal-state/standout-mode?! (screen-state screen) standout-mode?))
+
+(define-integrable (screen-insert-mode? screen)
+ (terminal-state/insert-mode? (screen-state screen)))
+
+(define-integrable (set-screen-insert-mode?! screen insert-mode?)
+ (set-terminal-state/insert-mode?! (screen-state screen) insert-mode?))
+
+(define-integrable (screen-delete-mode? screen)
+ (terminal-state/delete-mode? (screen-state screen)))
+
+(define-integrable (set-screen-delete-mode?! screen delete-mode?)
+ (set-terminal-state/delete-mode?! (screen-state screen) delete-mode?))
+
+(define-integrable (screen-scroll-region screen)
+ (terminal-state/scroll-region (screen-state screen)))
+
+(define-integrable (set-screen-scroll-region! screen scroll-region)
+ (set-terminal-state/scroll-region! (screen-state screen) scroll-region))
+\f
+;;;; Console Screen Operations
+
+(define (console-discard! screen)
+ screen
+ (set! console-description 'UNKNOWN)
+ unspecific)
+
+(define (console-enter! screen)
+ (maybe-output screen (ts-enter-termcap-mode (screen-description screen)))
+ (set-screen-cursor-x! screen false)
+ (set-screen-cursor-y! screen false))
+
+(define (console-exit! screen)
+ (let ((description (screen-description screen)))
+ (move-cursor screen 0 (fix:-1+ (tn-y-size description)))
+ (exit-standout-mode screen)
+ (exit-insert-mode screen)
+ (maybe-output screen (ts-exit-termcap-mode description)))
+ (output-port/flush-output console-output-port))
+
+(define (console-modeline-event! screen window type)
+ screen window type
+ unspecific)
+
+(define (console-wrap-update! screen thunk)
+ screen
+ (thunk)
+ (output-port/flush-output console-output-port))
+
+(define (console-preempt-update? screen y)
+ (and (fix:= 0 (fix:remainder y (screen-preemption-modulus screen)))
+ (begin
+ (let ((n (output-port/buffered-chars console-output-port)))
+ (if (fix:< 20 n)
+ (begin
+ (output-port/flush-output console-output-port)
+ (let ((baud-rate (screen-baud-rate screen)))
+ (if (fix:< baud-rate 2400)
+ (let ((msec (quotient (* n 10000) baud-rate)))
+ (if (>= msec 1000)
+ (let ((t (+ (real-time-clock) msec)))
+ (let loop ()
+ (if (< (real-time-clock) t)
+ (loop)))))))))))
+ true)))
+
+(define (console-beep screen)
+ (output-1 screen (ts-audible-bell (screen-description screen))))
+
+(define (console-flush! screen)
+ screen
+ (output-port/flush-output console-output-port))
+\f
+(define (console-write-cursor! screen x y)
+ (move-cursor screen x y))
+
+(define (console-write-char! screen x y char highlight)
+ (if (let ((description (screen-description screen)))
+ (not (and (tf-automatic-wrap description)
+ (fix:= x (fix:-1+ (tn-x-size description)))
+ (fix:= y (fix:-1+ (tn-y-size description))))))
+ (begin
+ (exit-insert-mode screen)
+ (move-cursor screen x y)
+ (highlight-if-desired screen highlight)
+ (output-char screen char)
+ (record-cursor-after-output screen (fix:1+ x)))))
+
+(define (console-write-substring! screen x y string start end highlight)
+ (if (fix:< start end)
+ (begin
+ (exit-insert-mode screen)
+ (move-cursor screen x y)
+ (highlight-if-desired screen highlight)
+ (let ((end
+ (if (let ((description (screen-description screen)))
+ (and (tf-automatic-wrap description)
+ (fix:= y (fix:-1+ (tn-y-size description)))
+ (fix:= (fix:+ x (fix:- end start))
+ (tn-x-size description))))
+ (fix:-1+ end)
+ end)))
+ (do ((i start (fix:1+ i)))
+ ((fix:= i end))
+ (output-char screen (string-ref string i)))
+ (record-cursor-after-output screen (fix:+ x (fix:- end start)))))))
+
+(define (console-clear-line! screen x y first-unused-x)
+ (move-cursor screen x y)
+ (clear-line screen first-unused-x))
+
+(define (console-clear-screen! screen)
+ (clear-screen screen))
+\f
+(define (console-clear-rectangle! screen xl xu yl yu highlight)
+ (let ((description (screen-description screen)))
+ (let ((x-size (tn-x-size description))
+ (y-size (tn-y-size description)))
+ (cond ((not (fix:= xu x-size))
+ (let ((n (fix:- xu xl)))
+ (do ((y yl (fix:1+ y)))
+ ((fix:= y yu))
+ (move-cursor screen xl y)
+ (clear-multi-char screen n))))
+ ((fix:= yl (fix:1+ yu))
+ (move-cursor screen xl yl)
+ (clear-line screen x-size))
+ ((and (fix:= xl 0) (fix:= yu y-size))
+ (if (fix:= yl 0)
+ (clear-screen screen)
+ (begin
+ (move-cursor screen 0 yl)
+ (clear-to-bottom screen))))
+ (else
+ (do ((y yl (fix:1+ y)))
+ ((fix:= y yu))
+ (move-cursor screen xl y)
+ (clear-line screen x-size)))))))
+
+(define (console-scroll-lines-down! screen xl xu yl yu amount)
+ (let ((description (screen-description screen)))
+ (and (insert/delete-line-ok? description)
+ (fix:= xl 0)
+ (fix:= xu (tn-x-size description))
+ (begin
+ (let ((y-size (tn-y-size description)))
+ (if (or (fix:= yu y-size)
+ (scroll-region-ok? description))
+ (insert-lines screen yl yu amount)
+ (begin
+ (delete-lines screen (fix:- yu amount) y-size amount)
+ (insert-lines screen yl y-size amount))))
+ 'CLEARED))))
+
+(define (console-scroll-lines-up! screen xl xu yl yu amount)
+ (let ((description (screen-description screen)))
+ (and (insert/delete-line-ok? description)
+ (fix:= xl 0)
+ (fix:= xu (tn-x-size description))
+ (begin
+ (let ((y-size (tn-y-size description)))
+ (if (or (fix:= yu y-size)
+ (scroll-region-ok? description))
+ (delete-lines screen yl yu amount)
+ (begin
+ (delete-lines screen yl y-size amount)
+ (insert-lines screen yu y-size amount))))
+ 'CLEARED))))
+\f
+;;;; Termcap Commands
+
+(define (clear-screen screen)
+ (let ((description (screen-description screen)))
+ (let ((ts-clear-screen (ts-clear-screen description)))
+ (if ts-clear-screen
+ (begin
+ (exit-standout-mode screen)
+ (output-n screen ts-clear-screen (tn-y-size description))
+ (set-screen-cursor-x! screen 0)
+ (set-screen-cursor-y! screen 0))
+ (begin
+ (move-cursor screen 0 0)
+ (clear-to-bottom screen))))))
+
+(define (clear-to-bottom screen)
+ (let ((description (screen-description screen)))
+ (let ((ts-clear-to-bottom (ts-clear-to-bottom description)))
+ (if ts-clear-to-bottom
+ (begin
+ (exit-standout-mode screen)
+ (output screen ts-clear-to-bottom))
+ (let ((x-size (tn-x-size description))
+ (y-size (tn-y-size description)))
+ (do ((y (screen-cursor-y screen) (fix:1+ y)))
+ ((fix:= y y-size))
+ (move-cursor screen 0 y)
+ (clear-line screen x-size)))))))
+
+(define (clear-line screen first-unused-x)
+ (exit-standout-mode screen)
+ (let ((description (screen-description screen)))
+ (let ((ts-clear-line (ts-clear-line description)))
+ (if ts-clear-line
+ (output-1 screen ts-clear-line)
+ (begin
+ (exit-insert-mode screen)
+ (let ((first-unused-x
+ (if (and (tf-automatic-wrap description)
+ (fix:= first-unused-x (tn-x-size description))
+ (fix:= (screen-cursor-y screen)
+ (fix:-1+ (tn-y-size description))))
+ (fix:-1+ first-unused-x)
+ first-unused-x)))
+ (do ((x (screen-cursor-x screen) (fix:1+ x)))
+ ((fix:= x first-unused-x))
+ (output-char screen #\space))
+ (record-cursor-after-output screen first-unused-x)))))))
+
+(define (clear-multi-char screen n)
+ (exit-standout-mode screen)
+ (let ((description (screen-description screen)))
+ (let ((ts-clear-multi-char (ts-clear-multi-char description)))
+ (if ts-clear-multi-char
+ (output-1 screen (parameterize-1 ts-clear-multi-char n))
+ (begin
+ (exit-insert-mode screen)
+ (let ((cursor-x (screen-cursor-x screen)))
+ (let ((x-end
+ (let ((x-end (fix:+ cursor-x n))
+ (x-size (tn-x-size description)))
+ (if (fix:> x-end x-size)
+ (error "can't clear past end of line"))
+ (if (and (fix:= x-end x-size)
+ (tf-automatic-wrap description)
+ (fix:= (screen-cursor-y screen)
+ (fix:-1+ (tn-y-size description))))
+ (fix:-1+ x-size)
+ x-end))))
+ (do ((x cursor-x (fix:1+ x)))
+ ((fix:= x x-end))
+ (output-char screen #\space))
+ (record-cursor-after-output screen x-end))))))))
+\f
+(define (insert-lines screen yl yu n)
+ (let ((description (screen-description screen))
+ (n-lines (fix:- yu yl)))
+ (let ((y-size (tn-y-size description)))
+ (cond ((ts-insert-line description)
+ =>
+ (lambda (ts-insert-line)
+ (if (not (fix:= yu y-size))
+ (set-scroll-region screen yl yu))
+ (move-cursor screen 0 yl)
+ (exit-standout-mode screen)
+ (let ((ts-insert-multi-line (ts-insert-multi-line description)))
+ (if (and (fix:> n 1) ts-insert-multi-line)
+ (output-n screen
+ (parameterize-1 ts-insert-multi-line n)
+ n-lines)
+ (do ((i 0 (fix:1+ i)))
+ ((fix:= i n))
+ (output-n screen ts-insert-line n-lines))))
+ (clear-scroll-region screen)))
+ ((ts-reverse-scroll description)
+ =>
+ (lambda (ts-reverse-scroll)
+ (set-scroll-region screen yl yu)
+ (move-cursor screen 0 yl)
+ (exit-standout-mode screen)
+ (do ((i 0 (fix:1+ i)))
+ ((fix:= i n))
+ (output-n screen ts-reverse-scroll n-lines))
+ (clear-scroll-region screen)
+ (if (and (tf-memory-above-screen description)
+ (fix:= yl 0)
+ (fix:= yu y-size))
+ (let ((x-size (tn-x-size description)))
+ (do ((y 0 (fix:1+ y)))
+ ((fix:= y n))
+ (move-cursor screen 0 y)
+ (clear-line screen x-size))))))
+ (else
+ (error "can't insert lines" screen))))))
+
+(define (delete-lines screen yl yu n)
+ (let ((description (screen-description screen))
+ (n-lines (fix:- yu yl)))
+ (let ((y-size (tn-y-size description)))
+ (cond ((ts-delete-line description)
+ =>
+ (lambda (ts-delete-line)
+ (if (not (fix:= yu y-size))
+ (set-scroll-region screen yl yu))
+ (move-cursor screen 0 yl)
+ (exit-standout-mode screen)
+ (let ((ts-delete-multi-line (ts-delete-multi-line description)))
+ (if (and (fix:> n 1) ts-delete-multi-line)
+ (output-n screen
+ (parameterize-1 ts-delete-multi-line n)
+ n-lines)
+ (do ((i 0 (fix:1+ i)))
+ ((fix:= i n))
+ (output-n screen ts-delete-line n-lines))))))
+ ((ts-forward-scroll description)
+ =>
+ (lambda (ts-forward-scroll)
+ (set-scroll-region screen yl yu)
+ (move-cursor screen 0 (fix:-1+ yu))
+ (exit-standout-mode screen)
+ (do ((i 0 (fix:1+ i)))
+ ((fix:= i n))
+ (output-n screen ts-forward-scroll n-lines))))
+ (else
+ (error "can't delete lines" screen)))
+ (if (and (tf-memory-below-screen description)
+ (not (screen-scroll-region screen))
+ (fix:> n 0))
+ (begin
+ (move-cursor screen 0 (fix:- y-size n))
+ (clear-to-bottom screen)))
+ (clear-scroll-region screen))))
+\f
+(define (set-scroll-region screen yl yu)
+ (let ((y-size (tn-y-size (screen-description screen))))
+ (if (and (fix:= yl 0) (fix:= yu y-size))
+ (clear-scroll-region screen)
+ (if (let ((scroll-region (screen-scroll-region screen)))
+ (not (and scroll-region
+ (fix:= yl (car scroll-region))
+ (fix:= yu (cdr scroll-region)))))
+ (begin
+ (%set-scroll-region screen yl yu)
+ (set-screen-scroll-region! screen (cons yl yu)))))))
+
+(define (clear-scroll-region screen)
+ (let ((scroll-region (screen-scroll-region screen)))
+ (if scroll-region
+ (begin
+ (%set-scroll-region screen 0 (tn-y-size (screen-description screen)))
+ (set-screen-scroll-region! screen false)))))
+
+(define (%set-scroll-region screen yl yu)
+ (output-1 screen
+ (let ((description (screen-description screen)))
+ (cond ((ts-set-scroll-region description)
+ =>
+ (lambda (ts-set-scroll-region)
+ (parameterize-2 ts-set-scroll-region yl (fix:-1+ yu))))
+ ((ts-set-scroll-region-1 description)
+ =>
+ (lambda (ts-set-scroll-region-1)
+ (let ((y-size (tn-y-size description)))
+ (parameterize-4 ts-set-scroll-region-1
+ y-size
+ yl
+ (fix:- y-size yu)
+ y-size))))
+ ((ts-set-window description)
+ =>
+ (lambda (ts-set-window)
+ (parameterize-4 ts-set-window
+ yl (fix:-1+ yu)
+ 0 (fix:-1+ (tn-x-size description)))))
+ (else
+ (error "can't set scroll region" screen)))))
+ (set-screen-cursor-x! screen false)
+ (set-screen-cursor-y! screen false))
+\f
+(define (highlight-if-desired screen highlight)
+ (if highlight
+ (enter-standout-mode screen)
+ (exit-standout-mode screen)))
+
+(define-integrable (enter-standout-mode screen)
+ ;; If the terminal uses standout markers, don't use standout.
+ ;; It's too complicated to bother with.
+ (if (and (not (screen-standout-mode? screen))
+ (not (tn-standout-marker-width (screen-description screen))))
+ (begin
+ (set-screen-standout-mode?! screen true)
+ (maybe-output-1
+ screen
+ (ts-enter-standout-mode (screen-description screen))))))
+
+(define-integrable (exit-standout-mode screen)
+ (if (screen-standout-mode? screen)
+ (begin
+ (set-screen-standout-mode?! screen false)
+ (maybe-output-1 screen
+ (ts-exit-standout-mode (screen-description screen))))))
+
+(define-integrable (enter-insert-mode screen)
+ (if (not (screen-insert-mode? screen))
+ (begin
+ (set-screen-insert-mode?! screen true)
+ (maybe-output-1 screen
+ (ts-enter-insert-mode (screen-description screen))))))
+
+(define-integrable (exit-insert-mode screen)
+ (if (screen-insert-mode? screen)
+ (begin
+ (set-screen-insert-mode?! screen false)
+ (maybe-output-1 screen
+ (ts-exit-insert-mode (screen-description screen))))))
+
+(define-integrable (enter-delete-mode screen)
+ (if (not (screen-delete-mode? screen))
+ (begin
+ (set-screen-delete-mode?! screen true)
+ (maybe-output-1 screen
+ (ts-enter-delete-mode (screen-description screen))))))
+
+(define-integrable (exit-delete-mode screen)
+ (if (screen-delete-mode? screen)
+ (begin
+ (set-screen-delete-mode?! screen false)
+ (maybe-output-1 screen
+ (ts-exit-delete-mode (screen-description screen))))))
+\f
+(define (move-cursor screen x y)
+ (let ((description (screen-description screen))
+ (cursor-x (screen-cursor-x screen))
+ (cursor-y (screen-cursor-y screen)))
+ (if (not (and cursor-x (fix:= x cursor-x) (fix:= y cursor-y)))
+ (let ((y-size (tn-y-size description))
+ (trivial-command (lambda (command) (output-1 screen command)))
+ (general-case
+ (lambda ()
+ (output-1 screen
+ (parameterize-2 (ts-cursor-move description)
+ y x)))))
+ (if (not (tf-standout-mode-motion description))
+ (exit-standout-mode screen))
+ (if (not (tf-insert-mode-motion description))
+ (exit-insert-mode screen))
+ (cond ((and (fix:= x 0)
+ (fix:= y 0)
+ (ts-cursor-upper-left description))
+ => trivial-command)
+ ((and (fix:= x 0)
+ (fix:= y (fix:-1+ y-size))
+ (ts-cursor-lower-left description))
+ => trivial-command)
+ ((not cursor-x)
+ (general-case))
+ ((fix:= y cursor-y)
+ (cond ((and (fix:= x (fix:-1+ cursor-x))
+ (ts-cursor-left description))
+ => trivial-command)
+ ((and (fix:= x (fix:1+ cursor-x))
+ (ts-cursor-right description))
+ => trivial-command)
+ ((and (fix:= x 0)
+ (ts-cursor-line-start description))
+ => trivial-command)
+ ((ts-cursor-move-x description)
+ =>
+ (lambda (ts-cursor-move-x)
+ (output-1 screen
+ (parameterize-1 ts-cursor-move-x x))))
+ (else
+ (general-case))))
+ ((fix:= x cursor-x)
+ (cond ((and (fix:= y (fix:-1+ cursor-y))
+ (ts-cursor-up description))
+ => trivial-command)
+ ((and (fix:= y (fix:1+ cursor-y))
+ (ts-cursor-down description))
+ => trivial-command)
+ (else
+ (general-case))))
+ (else
+ (general-case)))
+ (set-screen-cursor-x! screen x)
+ (set-screen-cursor-y! screen y)))))
+
+(define (record-cursor-after-output screen cursor-x)
+ (let ((description (screen-description screen)))
+ (let ((x-size (tn-x-size description)))
+ (cond ((fix:< cursor-x x-size)
+ (set-screen-cursor-x! screen cursor-x))
+ ((fix:> cursor-x x-size)
+ (error "wrote past end of line" cursor-x x-size))
+ ((or (tf-magic-wrap description)
+ (tf-lose-wrap description))
+ (set-screen-cursor-x! screen false)
+ (set-screen-cursor-y! screen false))
+ ((tf-automatic-wrap description)
+ (set-screen-cursor-x! screen 0)
+ (set-screen-cursor-y! screen (fix:1+ (screen-cursor-y screen))))
+ (else
+ (set-screen-cursor-x! screen (fix:-1+ x-size)))))))
+\f
+(define (pad-string screen string n-lines)
+ (termcap-pad-string string
+ n-lines
+ (screen-baud-rate-index screen)
+ (ts-pad-char (screen-description screen))))
+
+(define (goto-string screen string x y)
+ (let ((description (screen-description screen)))
+ (termcap-goto-string string x y
+ (ts-cursor-left description)
+ (ts-cursor-up description))))
+
+(define-integrable (parameterize-1 string p1)
+ (termcap-param-string string p1 0 0 0))
+
+(define-integrable (parameterize-2 string p1 p2)
+ (termcap-param-string string p1 p2 0 0))
+
+(define-integrable (parameterize-4 string p1 p2 p3 p4)
+ (termcap-param-string string p1 p2 p3 p4))
+
+(define (output screen command)
+ (output-n screen
+ command
+ (fix:- (let ((scroll-region (screen-scroll-region screen)))
+ (if scroll-region
+ (cdr scroll-region)
+ (tn-y-size (screen-description screen))))
+ (screen-cursor-y screen))))
+
+(define-integrable (output-1 screen command)
+ (output-n screen command 1))
+
+(define-integrable (output-n screen command n-lines)
+ (output-port/write-string console-output-port
+ (pad-string screen command n-lines)))
+
+(define (maybe-output screen command)
+ (if command
+ (output screen command)))
+
+(define-integrable (maybe-output-1 screen command)
+ (maybe-output-n screen command 1))
+
+(define (maybe-output-n screen command n-lines)
+ (if command
+ (output-n screen command n-lines)))
+
+(define-integrable (output-char screen char)
+ screen
+ (output-port/write-char console-output-port char))
\ No newline at end of file
projects / mit-scheme.git / commitdiff