/[slime]/slime/swank-gray.lisp
ViewVC logotype

Contents of /slime/swank-gray.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (hide annotations)
Sat Aug 30 15:33:49 2008 UTC (5 years, 7 months ago) by heller
Branch: MAIN
Changes since 1.17: +4 -10 lines
* swank-gray.lisp (slime-input-stream): Remove the output stream
slot.  Most of the time we can just call force-output.
1 heller 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2     ;;;
3     ;;; swank-gray.lisp --- Gray stream based IO redirection.
4     ;;;
5 heller 1.6 ;;; Created 2003
6 heller 1.1 ;;;
7     ;;; This code has been placed in the Public Domain. All warranties
8     ;;; are disclaimed.
9     ;;;
10    
11 heller 1.4 (in-package :swank-backend)
12 heller 1.1
13     (defclass slime-output-stream (fundamental-character-output-stream)
14 lgorrie 1.2 ((output-fn :initarg :output-fn)
15 heller 1.8 (buffer :initform (make-string 8000))
16 heller 1.1 (fill-pointer :initform 0)
17 heller 1.8 (column :initform 0)
18 heller 1.14 (lock :initform (make-lock :name "buffer write lock"))))
19 heller 1.1
20 heller 1.12 (defmacro with-slime-output-stream (stream &body body)
21     `(with-slots (lock output-fn buffer fill-pointer column) ,stream
22 heller 1.14 (call-with-lock-held lock (lambda () ,@body))))
23 heller 1.12
24 heller 1.1 (defmethod stream-write-char ((stream slime-output-stream) char)
25 heller 1.12 (with-slime-output-stream stream
26     (setf (schar buffer fill-pointer) char)
27     (incf fill-pointer)
28     (incf column)
29     (when (char= #\newline char)
30     (setf column 0))
31     (when (= fill-pointer (length buffer))
32     (finish-output stream)))
33 heller 1.1 char)
34    
35 heller 1.13 (defmethod stream-write-string ((stream slime-output-stream) string
36     &optional start end)
37     (with-slime-output-stream stream
38     (let* ((start (or start 0))
39     (end (or end (length string)))
40     (len (length buffer))
41     (count (- end start))
42     (free (- len fill-pointer)))
43     (when (>= count free)
44     (stream-finish-output stream))
45     (cond ((< count len)
46     (replace buffer string :start1 fill-pointer
47     :start2 start :end2 end)
48     (incf fill-pointer count))
49     (t
50     (funcall output-fn (subseq string start end))))
51     (let ((last-newline (position #\newline string :from-end t
52     :start start :end end)))
53     (setf column (if last-newline
54     (- end last-newline 1)
55     (+ column count))))))
56     string)
57    
58 heller 1.1 (defmethod stream-line-column ((stream slime-output-stream))
59 heller 1.12 (with-slime-output-stream stream column))
60 heller 1.1
61     (defmethod stream-line-length ((stream slime-output-stream))
62     75)
63    
64 heller 1.8 (defmethod stream-finish-output ((stream slime-output-stream))
65 heller 1.12 (with-slime-output-stream stream
66     (unless (zerop fill-pointer)
67     (funcall output-fn (subseq buffer 0 fill-pointer))
68     (setf fill-pointer 0)))
69 heller 1.8 nil)
70    
71     (defmethod stream-force-output ((stream slime-output-stream))
72 heller 1.12 (stream-finish-output stream))
73 heller 1.9
74     (defmethod stream-fresh-line ((stream slime-output-stream))
75 heller 1.12 (with-slime-output-stream stream
76     (cond ((zerop column) nil)
77     (t (terpri stream) t))))
78 heller 1.1
79     (defclass slime-input-stream (fundamental-character-input-stream)
80 heller 1.18 ((input-fn :initarg :input-fn)
81 nsiivola 1.10 (buffer :initform "") (index :initform 0)
82     (lock :initform (make-lock :name "buffer read lock"))))
83 heller 1.1
84     (defmethod stream-read-char ((s slime-input-stream))
85 nsiivola 1.10 (call-with-lock-held
86     (slot-value s 'lock)
87     (lambda ()
88 heller 1.18 (with-slots (buffer index input-fn) s
89 nsiivola 1.10 (when (= index (length buffer))
90     (let ((string (funcall input-fn)))
91     (cond ((zerop (length string))
92     (return-from stream-read-char :eof))
93     (t
94     (setf buffer string)
95     (setf index 0)))))
96     (assert (plusp (length buffer)))
97     (prog1 (aref buffer index) (incf index))))))
98 heller 1.1
99     (defmethod stream-listen ((s slime-input-stream))
100 nsiivola 1.10 (call-with-lock-held
101     (slot-value s 'lock)
102     (lambda ()
103     (with-slots (buffer index) s
104     (< index (length buffer))))))
105 heller 1.1
106     (defmethod stream-unread-char ((s slime-input-stream) char)
107 nsiivola 1.10 (call-with-lock-held
108     (slot-value s 'lock)
109     (lambda ()
110     (with-slots (buffer index) s
111     (decf index)
112     (cond ((eql (aref buffer index) char)
113     (setf (aref buffer index) char))
114     (t
115     (warn "stream-unread-char: ignoring ~S (expected ~S)"
116     char (aref buffer index)))))))
117 heller 1.1 nil)
118    
119     (defmethod stream-clear-input ((s slime-input-stream))
120 nsiivola 1.10 (call-with-lock-held
121     (slot-value s 'lock)
122     (lambda ()
123     (with-slots (buffer index) s
124     (setf buffer ""
125     index 0))))
126 heller 1.1 nil)
127    
128     (defmethod stream-line-column ((s slime-input-stream))
129     nil)
130    
131     (defmethod stream-line-length ((s slime-input-stream))
132     75)
133    
134 heller 1.3
135     ;;; CLISP extensions
136    
137     ;; We have to define an additional method for the sake of the C
138     ;; function listen_char (see src/stream.d), on which SYS::READ-FORM
139     ;; depends.
140    
141     ;; We could make do with either of the two methods below.
142    
143     (defmethod stream-read-char-no-hang ((s slime-input-stream))
144 nsiivola 1.10 (call-with-lock-held
145     (slot-value s 'lock)
146     (lambda ()
147     (with-slots (buffer index) s
148     (when (< index (length buffer))
149     (prog1 (aref buffer index) (incf index)))))))
150 heller 1.3
151     ;; This CLISP extension is what listen_char actually calls. The
152     ;; default method would call STREAM-READ-CHAR-NO-HANG, so it is a bit
153     ;; more efficient to define it directly.
154    
155     (defmethod stream-read-char-will-hang-p ((s slime-input-stream))
156     (with-slots (buffer index) s
157     (= index (length buffer))))
158    
159    
160     ;;;
161 heller 1.15
162     (defimplementation make-output-stream (write-string)
163 heller 1.16 (make-instance 'slime-output-stream :output-fn write-string))
164 heller 1.15
165     (defimplementation make-input-stream (read-string)
166 heller 1.18 (make-instance 'slime-input-stream :input-fn read-string))
167 heller 1.15
168 heller 1.4 (defimplementation make-fn-streams (input-fn output-fn)
169 heller 1.3 (let* ((output (make-instance 'slime-output-stream
170     :output-fn output-fn))
171     (input (make-instance 'slime-input-stream
172 heller 1.18 :input-fn input-fn)))
173 heller 1.17 (values input output)))

  ViewVC Help
Powered by ViewVC 1.1.5