/[cmucl]/src/hemlock/streams.lisp
ViewVC logotype

Contents of /src/hemlock/streams.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide annotations)
Mon May 4 01:27:20 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.4: +9 -9 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 ram 1.1 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.3 ;;; 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 dtc 1.5 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/streams.lisp,v 1.5 1998/05/04 01:27:20 dtc Rel $")
9 ram 1.3 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; This file contains definitions of various types of streams used
13     ;;; in Hemlock. They are implementation dependant, but should be
14     ;;; portable to all implementations based on Spice Lisp with little
15     ;;; difficulty.
16     ;;;
17     ;;; Written by Skef Wholey and Rob MacLachlan.
18     ;;;
19    
20     (in-package "HEMLOCK-INTERNALS")
21    
22     (export '(make-hemlock-output-stream
23     hemlock-region-stream hemlock-region-stream-p
24     hemlock-output-stream make-hemlock-region-stream
25     hemlock-output-stream-p make-kbdmac-stream
26     modify-kbdmac-stream))
27    
28     (defstruct (hemlock-output-stream
29 dtc 1.5 (:include sys:lisp-stream
30 ram 1.1 (:misc #'hemlock-output-misc))
31     (:print-function %print-hemlock-output-stream)
32     (:constructor internal-make-hemlock-output-stream ()))
33     ;;
34     ;; The mark we insert at.
35     mark)
36    
37     (defun %print-hemlock-output-stream (s stream d)
38     (declare (ignore d s))
39     (write-string "#<Hemlock output stream>" stream))
40    
41     (defun make-hemlock-output-stream (mark &optional (buffered :line))
42     "Returns an output stream whose output will be inserted at the Mark.
43     Buffered, which indicates to what extent the stream may be buffered
44     is one of the following:
45     :None -- The screen is brought up to date after each stream operation.
46     :Line -- The screen is brought up to date when a newline is written.
47     :Full -- The screen is not updated except explicitly via Force-Output."
48     (modify-hemlock-output-stream (internal-make-hemlock-output-stream) mark
49     buffered))
50    
51    
52     (defun modify-hemlock-output-stream (stream mark buffered)
53     (unless (and (markp mark)
54     (memq (mark-kind mark) '(:right-inserting :left-inserting)))
55     (error "~S is not a permanent mark." mark))
56     (setf (hemlock-output-stream-mark stream) mark)
57     (case buffered
58     (:none
59 dtc 1.5 (setf (lisp::lisp-stream-out stream) #'hemlock-output-unbuffered-out
60     (lisp::lisp-stream-sout stream) #'hemlock-output-unbuffered-sout))
61 ram 1.1 (:line
62 dtc 1.5 (setf (lisp::lisp-stream-out stream) #'hemlock-output-line-buffered-out
63     (lisp::lisp-stream-sout stream) #'hemlock-output-line-buffered-sout))
64 ram 1.1 (:full
65 dtc 1.5 (setf (lisp::lisp-stream-out stream) #'hemlock-output-buffered-out
66     (lisp::lisp-stream-sout stream) #'hemlock-output-buffered-sout))
67 ram 1.1 (t
68     (error "~S is a losing value for Buffered." buffered)))
69     stream)
70    
71     (defmacro with-left-inserting-mark ((var form) &body forms)
72     (let ((change (gensym)))
73     `(let* ((,var ,form)
74     (,change (eq (mark-kind ,var) :right-inserting)))
75     (unwind-protect
76     (progn
77     (when ,change
78     (setf (mark-kind ,var) :left-inserting))
79     ,@forms)
80     (when ,change
81     (setf (mark-kind ,var) :right-inserting))))))
82    
83     (defun hemlock-output-unbuffered-out (stream character)
84     (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
85     (insert-character mark character)
86     (redisplay-windows-from-mark mark)))
87    
88     (defun hemlock-output-unbuffered-sout (stream string start end)
89     (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
90     (insert-string mark string start end)
91     (redisplay-windows-from-mark mark)))
92    
93     (defun hemlock-output-buffered-out (stream character)
94     (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
95     (insert-character mark character)))
96    
97     (defun hemlock-output-buffered-sout (stream string start end)
98     (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
99     (insert-string mark string start end)))
100    
101     (defun hemlock-output-line-buffered-out (stream character)
102     (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
103     (insert-character mark character)
104     (when (char= character #\newline)
105     (redisplay-windows-from-mark mark))))
106    
107     (defun hemlock-output-line-buffered-sout (stream string start end)
108     (declare (simple-string string))
109     (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
110     (insert-string mark string start end)
111     (when (find #\newline string :start start :end end)
112     (redisplay-windows-from-mark mark))))
113    
114     (defun hemlock-output-misc (stream operation &optional arg1 arg2)
115     (declare (ignore arg1 arg2))
116     (case operation
117     (:charpos (mark-charpos (hemlock-output-stream-mark stream)))
118     (:line-length
119     (let* ((buffer (line-buffer (mark-line (hemlock-output-stream-mark stream)))))
120     (when buffer
121     (do ((w (buffer-windows buffer) (cdr w))
122     (min most-positive-fixnum (min (window-width (car w)) min)))
123     ((null w)
124     (if (/= min most-positive-fixnum) min))))))
125     ((:finish-output :force-output)
126     (redisplay-windows-from-mark (hemlock-output-stream-mark stream)))
127     (:close (setf (hemlock-output-stream-mark stream) nil))
128 ram 1.3 (:element-type 'base-char)))
129 ram 1.1
130     (defstruct (hemlock-region-stream
131 dtc 1.5 (:include sys:lisp-stream
132 ram 1.1 (:in #'region-in)
133 ram 1.3 (:misc #'region-misc))
134 ram 1.1 (:print-function %print-region-stream)
135     (:constructor internal-make-hemlock-region-stream (region mark)))
136     ;;
137     ;; The region we read from.
138     region
139     ;;
140     ;; The mark pointing to the next character to read.
141     mark)
142    
143     (defun %print-region-stream (s stream d)
144     (declare (ignore s d))
145     (write-string "#<Hemlock region stream>" stream))
146    
147     (defun make-hemlock-region-stream (region)
148     "Returns an input stream that will return successive characters from the
149     given Region when asked for input."
150     (internal-make-hemlock-region-stream
151     region (copy-mark (region-start region) :right-inserting)))
152    
153     (defun modify-hemlock-region-stream (stream region)
154 ram 1.3 (setf (hemlock-region-stream-region stream) region)
155 ram 1.1 (let* ((mark (hemlock-region-stream-mark stream))
156     (start (region-start region))
157     (start-line (mark-line start)))
158     ;; Make sure it's dead.
159     (delete-mark mark)
160     (setf (mark-line mark) start-line (mark-charpos mark) (mark-charpos start))
161     (push mark (line-marks start-line)))
162     stream)
163    
164     (defun region-in (stream eof-errorp eof-value)
165 ram 1.3 (let ((mark (hemlock-region-stream-mark stream)))
166     (cond ((mark< mark
167     (region-end (hemlock-region-stream-region stream)))
168     (prog1 (next-character mark) (mark-after mark)))
169     (eof-errorp (error "~A hit end of file." stream))
170     (t eof-value))))
171 ram 1.1
172     (defun region-misc (stream operation &optional arg1 arg2)
173 ram 1.3 (declare (ignore arg2))
174 ram 1.1 (case operation
175     (:listen (mark< (hemlock-region-stream-mark stream)
176     (region-end (hemlock-region-stream-region stream))))
177     (:clear-input (move-mark
178     (hemlock-region-stream-mark stream)
179     (region-end (hemlock-region-stream-region stream))))
180 ram 1.3 (:unread
181     (let ((mark (hemlock-region-stream-mark stream)))
182     (unless (mark> mark
183     (region-start (hemlock-region-stream-region stream)))
184     (error "Nothing to unread."))
185     (unless (char= arg1 (previous-character mark))
186     (error "Unreading something not read: ~S" arg1))
187     (mark-before mark)))
188     (:file-position
189     (let ((start (region-start (hemlock-region-stream-region stream)))
190     (mark (hemlock-region-stream-mark stream)))
191     (cond (arg1
192     (move-mark mark start)
193     (character-offset mark arg1))
194     (t
195     (count-characters (region start mark))))))
196 ram 1.1 (:close
197     (delete-mark (hemlock-region-stream-mark stream))
198     (setf (hemlock-region-stream-region stream) nil))
199 ram 1.3 (:element-type 'base-char)))
200 ram 1.1
201     ;;;; Stuff to support keyboard macros.
202    
203     (defstruct (kbdmac-stream
204 ram 1.2 (:include editor-input
205     (:get #'kbdmac-get)
206     (:unget #'kbdmac-unget)
207     (:listen #'kbdmac-listen))
208 ram 1.1 (:constructor make-kbdmac-stream ()))
209 ram 1.2 buffer ; The simple-vector that holds the characters.
210     index) ; Index of the next character.
211 ram 1.1
212 ram 1.2 (defun kbdmac-get (stream ignore-abort-attempts-p)
213     (declare (ignore ignore-abort-attempts-p))
214 ram 1.1 (let ((index (kbdmac-stream-index stream)))
215 ram 1.2 (setf (kbdmac-stream-index stream) (1+ index))
216     (setq *last-key-event-typed*
217     (svref (kbdmac-stream-buffer stream) index))))
218 ram 1.1
219 ram 1.2 (defun kbdmac-unget (ignore stream)
220     (declare (ignore ignore))
221     (if (plusp (kbdmac-stream-index stream))
222     (decf (kbdmac-stream-index stream))
223     (error "Nothing to unread.")))
224    
225     (defun kbdmac-listen (stream)
226     (declare (ignore stream))
227 ram 1.1 t)
228    
229 ram 1.2 ;;; MODIFY-KBDMAC-STREAM -- Internal
230 ram 1.1 ;;;
231     ;;; Bash the kbdmac-stream Stream so that it will return the Input.
232     ;;;
233     (defun modify-kbdmac-stream (stream input)
234     (setf (kbdmac-stream-index stream) 0)
235     (setf (kbdmac-stream-buffer stream) input)
236     stream)

  ViewVC Help
Powered by ViewVC 1.1.5