/[cmucl]/src/hemlock/tty-disp-rt.lisp
ViewVC logotype

Contents of /src/hemlock/tty-disp-rt.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Thu Dec 6 19:15:43 2001 UTC (12 years, 4 months ago) by pmai
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.6: +7 -7 lines
Added specialised port to OpenBSD (2.9).  Many parts of the original
code which were previously conditionalized on :FreeBSD, are now
conditionalized on :BSD instead, with the :BSD feature now implying a
4.4BSD(lite2) derived OS.  This should make future BSD-ports easier.
FreeBSD and OpenBSD are differentiated by having either :FreeBSD or
:OpenBSD on the features list.

Currently the OpenBSD port does not have working ELF support, because
OpenBSD 2.9 is still non-ELF by default.  So don't put ELF on the
features list when building for OpenBSD, or fix the code to work
correctly in this case instead.
1 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/tty-disp-rt.lisp,v 1.7 2001/12/06 19:15:43 pmai Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Written by Bill Chiles.
13 ;;;
14
15 (in-package "HEMLOCK-INTERNALS")
16
17
18 ;;;; Terminal init and exit methods.
19
20 (defvar *hemlock-input-handler*)
21
22 (defun init-tty-device (device)
23 (setf *hemlock-input-handler*
24 (system:add-fd-handler 0 :input #'get-editor-tty-input))
25 (standard-device-init)
26 (device-write-string (tty-device-init-string device))
27 (redisplay-all))
28
29 (defun exit-tty-device (device)
30 (cursor-motion device 0 (1- (tty-device-lines device)))
31 ;; Can't call the clear-to-eol method since we don't have a hunk to
32 ;; call it on, and you can't count on the bottom hunk being the echo area.
33 ;;
34 (if (tty-device-clear-to-eol-string device)
35 (device-write-string (tty-device-clear-to-eol-string device))
36 (dotimes (i (tty-device-columns device)
37 (cursor-motion device 0 (1- (tty-device-lines device))))
38 (tty-write-char #\space)))
39 (device-write-string (tty-device-cm-end-string device))
40 (when (device-force-output device)
41 (funcall (device-force-output device)))
42 (when *hemlock-input-handler*
43 (system:remove-fd-handler *hemlock-input-handler*)
44 (setf *hemlock-input-handler* nil))
45 (standard-device-exit))
46
47
48 ;;;; Get terminal attributes:
49
50 (defvar *terminal-baud-rate* nil)
51 (declaim (type (or (unsigned-byte 24) null) *terminal-baud-rate*))
52
53 ;;; GET-TERMINAL-ATTRIBUTES -- Interface
54 ;;;
55 ;;; Get terminal attributes from Unix. Return as values, the lines,
56 ;;; columns and speed. If any value is inaccessible, return NIL for that
57 ;;; value. We also sleazily cache the speed in *terminal-baud-rate*, since I
58 ;;; don't want to figure out how to get my hands on the TTY-DEVICE at the place
59 ;;; where I need it. Currently, there really can only be one TTY anyway, since
60 ;;; the buffer is in a global.
61 ;;;
62 (defun get-terminal-attributes (&optional (fd 1))
63 (alien:with-alien ((winsize (alien:struct unix:winsize))
64 #-(or glibc2 bsd)
65 (sgtty (alien:struct unix:sgttyb))
66 #+bsd ; termios
67 (tios (alien:struct unix:termios)))
68 (let ((size-win (unix:unix-ioctl fd unix:TIOCGWINSZ
69 (alien:alien-sap winsize)))
70 #-(or glibc2 bsd)
71 (speed-win (unix:unix-ioctl fd unix:TIOCGETP
72 (alien:alien-sap sgtty)))
73 #+bsd
74 (speed-win (unix:unix-tcgetattr fd (alien:alien-sap tios))))
75 (flet ((frob (val)
76 (if (and size-win (not (zerop val)))
77 val
78 nil)))
79 (values
80 (frob (alien:slot winsize 'unix:ws-row))
81 (frob (alien:slot winsize 'unix:ws-col))
82 #-(or glibc2 bsd)
83 (and speed-win
84 (setq *terminal-baud-rate*
85 (svref unix:terminal-speeds
86 (alien:slot sgtty 'unix:sg-ospeed))))
87 #+bsd
88 (and speed-win
89 (setq *terminal-baud-rate* (unix:unix-cfgetospeed tios)))
90 #+glibc2
91 4800)))))
92
93
94 ;;;; Output routines and buffering.
95
96 (defconstant redisplay-output-buffer-length 256)
97
98 (defvar *redisplay-output-buffer*
99 (make-string redisplay-output-buffer-length))
100 (declaim (simple-string *redisplay-output-buffer*))
101
102 (defvar *redisplay-output-buffer-index* 0)
103 (declaim (fixnum *redisplay-output-buffer-index*))
104
105 ;;; WRITE-AND-MAYBE-WAIT -- Internal
106 ;;;
107 ;;; Write the first Count characters in the redisplay output buffer. If
108 ;;; *terminal-baud-rate* is set, then sleep for long enough to allow the
109 ;;; written text to be displayed. We multiply by 10 to get the baud-per-byte
110 ;;; conversion, which assumes 7 character bits + 1 start bit + 2 stop bits, no
111 ;;; parity.
112 ;;;
113 (defun write-and-maybe-wait (count)
114 (declare (fixnum count))
115 (unix:unix-write 1 *redisplay-output-buffer* 0 count)
116 (let ((speed *terminal-baud-rate*))
117 (when speed
118 (sleep (/ (* (float count) 10.0) (float speed))))))
119
120
121 ;;; TTY-WRITE-STRING blasts the string into the redisplay output buffer.
122 ;;; If the string overflows the buffer, then segments of the string are
123 ;;; blasted into the buffer, dumping the buffer, until the last piece of
124 ;;; the string is stored in the buffer. The buffer is always dumped if
125 ;;; it is full, even if the last piece of the string just fills the buffer.
126 ;;;
127 (defun tty-write-string (string start length)
128 (declare (fixnum start length))
129 (let ((buffer-space (- redisplay-output-buffer-length
130 *redisplay-output-buffer-index*)))
131 (declare (fixnum buffer-space))
132 (cond ((<= length buffer-space)
133 (let ((dst-index (+ *redisplay-output-buffer-index* length)))
134 (%primitive byte-blt string start *redisplay-output-buffer*
135 *redisplay-output-buffer-index* dst-index)
136 (cond ((= length buffer-space)
137 (write-and-maybe-wait redisplay-output-buffer-length)
138 (setf *redisplay-output-buffer-index* 0))
139 (t
140 (setf *redisplay-output-buffer-index* dst-index)))))
141 (t
142 (let ((remaining (- length buffer-space)))
143 (declare (fixnum remaining))
144 (loop
145 (%primitive byte-blt string start *redisplay-output-buffer*
146 *redisplay-output-buffer-index*
147 redisplay-output-buffer-length)
148 (write-and-maybe-wait redisplay-output-buffer-length)
149 (when (< remaining redisplay-output-buffer-length)
150 (%primitive byte-blt string (+ start buffer-space)
151 *redisplay-output-buffer* 0 remaining)
152 (setf *redisplay-output-buffer-index* remaining)
153 (return t))
154 (incf start buffer-space)
155 (setf *redisplay-output-buffer-index* 0)
156 (setf buffer-space redisplay-output-buffer-length)
157 (decf remaining redisplay-output-buffer-length)))))))
158
159
160 ;;; TTY-WRITE-CHAR stores a character in the redisplay output buffer,
161 ;;; dumping the buffer if it becomes full.
162 ;;;
163 (defun tty-write-char (char)
164 (setf (schar *redisplay-output-buffer* *redisplay-output-buffer-index*)
165 char)
166 (incf *redisplay-output-buffer-index*)
167 (when (= *redisplay-output-buffer-index* redisplay-output-buffer-length)
168 (write-and-maybe-wait redisplay-output-buffer-length)
169 (setf *redisplay-output-buffer-index* 0)))
170
171
172 ;;; TTY-FORCE-OUTPUT dumps the redisplay output buffer. This is called
173 ;;; out of terminal device structures in multiple places -- the device
174 ;;; exit method, random typeout methods, out of tty-hunk-stream methods,
175 ;;; after calls to REDISPLAY or REDISPLAY-ALL.
176 ;;;
177 (defun tty-force-output ()
178 (unless (zerop *redisplay-output-buffer-index*)
179 (write-and-maybe-wait *redisplay-output-buffer-index*)
180 (setf *redisplay-output-buffer-index* 0)))
181
182
183 ;;; TTY-FINISH-OUTPUT simply dumps output.
184 ;;;
185 (defun tty-finish-output (device window)
186 (declare (ignore window))
187 (let ((force-output (device-force-output device)))
188 (when force-output
189 (funcall force-output))))
190
191
192
193 ;;;; Screen image line hacks.
194
195 (defmacro replace-si-line (dst-string src-string src-start dst-start dst-end)
196 `(%primitive byte-blt ,src-string ,src-start ,dst-string ,dst-start ,dst-end))

  ViewVC Help
Powered by ViewVC 1.1.5