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

Contents of /slime/swank-gray.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (hide annotations)
Mon Aug 4 20:25:38 2008 UTC (5 years, 8 months ago) by heller
Branch: MAIN
Changes since 1.10: +12 -19 lines
* swank-gray.lisp (slime-output-stream): Add a slot
"interactive-p" which should be true for streams which are flushed
periodically by the Lisp system.  Update the relevant accordingly.
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.11 ;; true if the Lisp system flushes this stream periodically
19     (interactive-p :initform nil)
20 nsiivola 1.10 (lock :initform (make-recursive-lock :name "buffer write lock"))))
21 heller 1.1
22     (defmethod stream-write-char ((stream slime-output-stream) char)
23 nsiivola 1.10 (call-with-recursive-lock-held
24     (slot-value stream 'lock)
25     (lambda ()
26     (with-slots (buffer fill-pointer column) stream
27     (setf (schar buffer fill-pointer) char)
28     (incf fill-pointer)
29     (incf column)
30     (when (char= #\newline char)
31     (setf column 0)
32     (force-output stream))
33     (when (= fill-pointer (length buffer))
34     (finish-output stream)))))
35 heller 1.1 char)
36    
37     (defmethod stream-line-column ((stream slime-output-stream))
38 nsiivola 1.10 (call-with-recursive-lock-held
39     (slot-value stream 'lock)
40     (lambda ()
41     (slot-value stream 'column))))
42 heller 1.1
43     (defmethod stream-line-length ((stream slime-output-stream))
44     75)
45    
46 heller 1.8 (defmethod stream-finish-output ((stream slime-output-stream))
47 heller 1.11 (with-slots (buffer lock fill-pointer output-fn) stream
48     (call-with-recursive-lock-held
49     lock
50     (lambda ()
51     (unless (zerop fill-pointer)
52     (funcall output-fn (subseq buffer 0 fill-pointer))
53     (setf fill-pointer 0)))))
54 heller 1.8 nil)
55    
56     (defmethod stream-force-output ((stream slime-output-stream))
57 heller 1.11 (with-slots (interactive-p) stream
58     (unless interactive-p
59     (stream-finish-output stream)))
60 heller 1.1 nil)
61 heller 1.9
62     (defmethod stream-fresh-line ((stream slime-output-stream))
63 nsiivola 1.10 (call-with-recursive-lock-held
64     (slot-value stream 'lock)
65     (lambda ()
66     (with-slots (column) stream
67     (cond ((zerop column) nil)
68     (t (terpri stream) t))))))
69 heller 1.1
70     (defclass slime-input-stream (fundamental-character-input-stream)
71 lgorrie 1.2 ((output-stream :initarg :output-stream)
72     (input-fn :initarg :input-fn)
73 nsiivola 1.10 (buffer :initform "") (index :initform 0)
74     (lock :initform (make-lock :name "buffer read lock"))))
75 heller 1.1
76     (defmethod stream-read-char ((s slime-input-stream))
77 nsiivola 1.10 (call-with-lock-held
78     (slot-value s 'lock)
79     (lambda ()
80     (with-slots (buffer index output-stream input-fn) s
81     (when (= index (length buffer))
82     (when output-stream
83     (finish-output output-stream))
84     (let ((string (funcall input-fn)))
85     (cond ((zerop (length string))
86     (return-from stream-read-char :eof))
87     (t
88     (setf buffer string)
89     (setf index 0)))))
90     (assert (plusp (length buffer)))
91     (prog1 (aref buffer index) (incf index))))))
92 heller 1.1
93     (defmethod stream-listen ((s slime-input-stream))
94 nsiivola 1.10 (call-with-lock-held
95     (slot-value s 'lock)
96     (lambda ()
97     (with-slots (buffer index) s
98     (< index (length buffer))))))
99 heller 1.1
100     (defmethod stream-unread-char ((s slime-input-stream) char)
101 nsiivola 1.10 (call-with-lock-held
102     (slot-value s 'lock)
103     (lambda ()
104     (with-slots (buffer index) s
105     (decf index)
106     (cond ((eql (aref buffer index) char)
107     (setf (aref buffer index) char))
108     (t
109     (warn "stream-unread-char: ignoring ~S (expected ~S)"
110     char (aref buffer index)))))))
111 heller 1.1 nil)
112    
113     (defmethod stream-clear-input ((s slime-input-stream))
114 nsiivola 1.10 (call-with-lock-held
115     (slot-value s 'lock)
116     (lambda ()
117     (with-slots (buffer index) s
118     (setf buffer ""
119     index 0))))
120 heller 1.1 nil)
121    
122     (defmethod stream-line-column ((s slime-input-stream))
123     nil)
124    
125     (defmethod stream-line-length ((s slime-input-stream))
126     75)
127    
128 heller 1.3
129     ;;; CLISP extensions
130    
131     ;; We have to define an additional method for the sake of the C
132     ;; function listen_char (see src/stream.d), on which SYS::READ-FORM
133     ;; depends.
134    
135     ;; We could make do with either of the two methods below.
136    
137     (defmethod stream-read-char-no-hang ((s slime-input-stream))
138 nsiivola 1.10 (call-with-lock-held
139     (slot-value s 'lock)
140     (lambda ()
141     (with-slots (buffer index) s
142     (when (< index (length buffer))
143     (prog1 (aref buffer index) (incf index)))))))
144 heller 1.3
145     ;; This CLISP extension is what listen_char actually calls. The
146     ;; default method would call STREAM-READ-CHAR-NO-HANG, so it is a bit
147     ;; more efficient to define it directly.
148    
149     (defmethod stream-read-char-will-hang-p ((s slime-input-stream))
150     (with-slots (buffer index) s
151     (= index (length buffer))))
152    
153    
154     ;;;
155 heller 1.4 (defimplementation make-fn-streams (input-fn output-fn)
156 heller 1.3 (let* ((output (make-instance 'slime-output-stream
157     :output-fn output-fn))
158     (input (make-instance 'slime-input-stream
159     :input-fn input-fn
160     :output-stream output)))
161     (values input output)))

  ViewVC Help
Powered by ViewVC 1.1.5