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

Contents of /src/hemlock/tty-stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Mon May 4 01:27:21 1998 UTC (15 years, 11 months ago) by dtc
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.3: +2 -2 lines
Gray streams support:
* Rename the 'stream structure class to sys:lisp-stream.
* Add a new none hierarchical 'stream built-in class which inherits
  from: instance, t.
* Hack in the new stream class as a mixin for the structure base
  lisp-stream class which now inherits from: stream, structure-object,
  instance, t.
* Add a new 'fundamental-stream standard-class which includes 'stream
  as a mixin, and add PCL hacks to allow this to be redefined after PCL is
  loaded to be (defclass fundamental-stream (standard-object stream) ...).
* Add appropriate support to the base stream functions to dispatch to
  the Gray stream functions for the handling of fundamental-streams.
  Some of the lisp-streams encapsulating CLOS streams still need
  a little work.
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-stream.lisp,v 1.4 1998/05/04 01:27:21 dtc Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Some stuff to make streams that write out to terminal hunks.
13 ;;;
14 ;;; Written by Bill Chiles.
15 ;;;
16 ;;; This code is VERY similar to that in Pane-Stream.Lisp. The biggest
17 ;;; (if only) difference is in TTY-HUNK-STREAM-NEWLINE.
18 ;;;
19
20 (in-package "HEMLOCK-INTERNALS")
21
22
23
24 ;;;; Constants
25
26 (defconstant tty-hunk-width-limit 200)
27
28
29
30 ;;;; Structures
31
32 ;;; Tty-Hunk streams are inherently buffered by line.
33
34 (defstruct (stream-hunk (:print-function %print-device-hunk)
35 (:include tty-hunk))
36 (width 0 :type fixnum)
37 (point-x 0 :type fixnum)
38 (point-y 0 :type fixnum)
39 (buffer "" :type simple-string))
40
41 (defstruct (tty-hunk-output-stream (:include sys:lisp-stream
42 (out #'hunk-out)
43 (sout #'hunk-sout)
44 (misc #'hunk-misc))
45 (:constructor
46 make-tty-hunk-output-stream ()))
47 (hunk (make-stream-hunk :buffer (make-string tty-hunk-width-limit))))
48
49
50
51 ;;;; Tty-hunk-output-stream methods
52
53 ;;; HUNK-OUT puts a character into a hunk-stream buffer. If the character
54 ;;; makes the current line wrap, or if the character is a newline, then
55 ;;; call TTY-HUNK-NEWLINE.
56 ;;;
57 (defun hunk-out (stream character)
58 (let* ((hunk (tty-hunk-output-stream-hunk stream))
59 (x (stream-hunk-point-x hunk)))
60 (declare (fixnum x))
61 (cond ((char= character #\newline)
62 (tty-hunk-stream-newline hunk)
63 (return-from hunk-out nil))
64 ((= x (the fixnum (stream-hunk-width hunk)))
65 (setf x 0)
66 (tty-hunk-stream-newline hunk)))
67 (setf (schar (stream-hunk-buffer hunk) x) character)
68 (incf (stream-hunk-point-x hunk))))
69
70 ;;; HUNK-MISC, when finishing or forcing output, only needs to blast
71 ;;; out the buffer at y from 0 to x since these streams are inherently
72 ;;; line buffered. Currently, these characters will be blasted out again
73 ;;; since there isn't a separate buffer index from point-x, and we can't
74 ;;; set point-x to zero since we haven't a newline.
75 ;;;
76 (defun hunk-misc (stream operation &optional arg1 arg2)
77 (declare (ignore arg1 arg2))
78 (case operation
79 (:charpos
80 (let ((hunk (tty-hunk-output-stream-hunk stream)))
81 (values (stream-hunk-point-x hunk) (stream-hunk-point-y hunk))))
82 ((:finish-output :force-output)
83 (let* ((hunk (tty-hunk-output-stream-hunk stream))
84 (device (device-hunk-device hunk)))
85 (funcall (tty-device-display-string device)
86 hunk 0 (stream-hunk-point-y hunk) (stream-hunk-buffer hunk)
87 0 (stream-hunk-point-x hunk))
88 (when (device-force-output device)
89 (funcall (device-force-output device)))))
90 (:line-length
91 (stream-hunk-width (tty-hunk-output-stream-hunk stream)))
92 (:element-type 'base-char)))
93
94 ;;; HUNK-SOUT writes a byte-blt's a string to a hunk-stream's buffer.
95 ;;; When newlines are found, recurse on the substrings delimited by start,
96 ;;; end, and newlines. If the string causes line wrapping, then we break
97 ;;; the string up into line-at-a-time segments calling TTY-HUNK-STREAM-NEWLINE.
98 ;;;
99 (defun hunk-sout (stream string start end)
100 (declare (fixnum start end))
101 (let* ((hunk (tty-hunk-output-stream-hunk stream))
102 (buffer (stream-hunk-buffer hunk))
103 (x (stream-hunk-point-x hunk))
104 (dst-end (+ x (- end start)))
105 (width (stream-hunk-width hunk))
106 (newlinep (%sp-find-character string start end #\newline)))
107 (declare (fixnum x dst-end width))
108 (cond (newlinep
109 (let ((previous start) (current newlinep))
110 (declare (fixnum previous))
111 (loop (when (null current)
112 (hunk-sout stream string previous end)
113 (return))
114 (hunk-sout stream string previous current)
115 (tty-hunk-stream-newline hunk)
116 (setf previous (the fixnum (1+ (the fixnum current))))
117 (setf current
118 (%sp-find-character string previous end #\newline)))))
119 ((> dst-end width)
120 (let ((new-start (+ start (- width x))))
121 (declare (fixnum new-start))
122 (%primitive byte-blt string start buffer x width)
123 (setf (stream-hunk-point-x hunk) width)
124 (tty-hunk-stream-newline hunk)
125 (do ((idx (+ new-start width) (+ idx width))
126 (prev new-start idx))
127 ((>= idx end)
128 (let ((dst-end (- end prev)))
129 (%primitive byte-blt string prev buffer 0 dst-end)
130 (setf (stream-hunk-point-x hunk) dst-end)))
131 (declare (fixnum prev idx))
132 (%primitive byte-blt string prev buffer 0 width)
133 (setf (stream-hunk-point-x hunk) width)
134 (tty-hunk-stream-newline hunk))))
135 (t
136 (%primitive byte-blt string start buffer x dst-end)
137 (setf (stream-hunk-point-x hunk) dst-end)))))
138
139 ;;; TTY-HUNK-STREAM-NEWLINE is the only place we display lines and affect
140 ;;; point-y. We also blast out the buffer in HUNK-MISC.
141 ;;;
142 (defun tty-hunk-stream-newline (hunk)
143 (let* ((device (device-hunk-device hunk))
144 (force-output-fun (device-force-output device))
145 (y (stream-hunk-point-y hunk)))
146 (declare (fixnum y))
147 (when (= y (the fixnum (device-hunk-position hunk)))
148 (funcall (tty-device-display-string device) hunk 0 y "--More--" 0 8)
149 (when force-output-fun (funcall force-output-fun))
150 (wait-for-more)
151 (funcall (tty-device-clear-to-eow device) hunk 0 0)
152 (setf (stream-hunk-point-y hunk) 0)
153 (setf y 0))
154 (funcall (tty-device-display-string device)
155 hunk 0 y (stream-hunk-buffer hunk) 0 (stream-hunk-point-x hunk))
156 (when force-output-fun (funcall force-output-fun))
157 (setf (stream-hunk-point-x hunk) 0)
158 (incf (stream-hunk-point-y hunk))))

  ViewVC Help
Powered by ViewVC 1.1.5