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

Contents of /slime/swank-gray.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5