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

Contents of /slime/swank-gray.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (hide annotations)
Wed Jan 19 18:28:37 2005 UTC (9 years, 2 months ago) by heller
Branch: MAIN
CVS Tags: SLIME-1-2, SLIME-1-2-1
Changes since 1.6: +6 -1 lines
(stream-unread-char): If the char argument doesn't match the contents
in the buffer ignore it and emit a warning instead.
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     (buffer :initform (make-string 512))
16 heller 1.1 (fill-pointer :initform 0)
17     (column :initform 0)))
18    
19     (defmethod stream-write-char ((stream slime-output-stream) char)
20     (with-slots (buffer fill-pointer column) stream
21     (setf (schar buffer fill-pointer) char)
22     (incf fill-pointer)
23     (incf column)
24     (when (char= #\newline char)
25     (setf column 0))
26     (when (= fill-pointer (length buffer))
27     (force-output stream)))
28     char)
29    
30     (defmethod stream-line-column ((stream slime-output-stream))
31     (slot-value stream 'column))
32    
33     (defmethod stream-line-length ((stream slime-output-stream))
34     75)
35    
36     (defmethod stream-force-output ((stream slime-output-stream))
37 lgorrie 1.2 (with-slots (buffer fill-pointer output-fn) stream
38 heller 1.1 (let ((end fill-pointer))
39     (unless (zerop end)
40 lgorrie 1.2 (funcall output-fn (subseq buffer 0 end))
41 heller 1.1 (setf fill-pointer 0))))
42     nil)
43    
44     (defclass slime-input-stream (fundamental-character-input-stream)
45 lgorrie 1.2 ((output-stream :initarg :output-stream)
46     (input-fn :initarg :input-fn)
47     (buffer :initform "") (index :initform 0)))
48 heller 1.1
49     (defmethod stream-read-char ((s slime-input-stream))
50 lgorrie 1.2 (with-slots (buffer index output-stream input-fn) s
51 heller 1.1 (when (= index (length buffer))
52 lgorrie 1.2 (when output-stream
53     (force-output output-stream))
54 heller 1.6 (let ((string (funcall input-fn)))
55     (cond ((zerop (length string))
56     (return-from stream-read-char :eof))
57     (t
58     (setf buffer string)
59     (setf index 0)))))
60 heller 1.1 (assert (plusp (length buffer)))
61     (prog1 (aref buffer index) (incf index))))
62    
63     (defmethod stream-listen ((s slime-input-stream))
64     (with-slots (buffer index) s
65     (< index (length buffer))))
66    
67     (defmethod stream-unread-char ((s slime-input-stream) char)
68     (with-slots (buffer index) s
69 heller 1.7 (decf index)
70     (cond ((eql (aref buffer index) char)
71     (setf (aref buffer index) char))
72     (t
73     (warn "stream-unread-char: ignoring ~S (expected ~S)"
74     char (aref buffer index)))))
75 heller 1.1 nil)
76    
77     (defmethod stream-clear-input ((s slime-input-stream))
78     (with-slots (buffer index) s
79     (setf buffer ""
80     index 0))
81     nil)
82    
83     (defmethod stream-line-column ((s slime-input-stream))
84     nil)
85    
86     (defmethod stream-line-length ((s slime-input-stream))
87     75)
88    
89 heller 1.3
90     ;;; CLISP extensions
91    
92     ;; We have to define an additional method for the sake of the C
93     ;; function listen_char (see src/stream.d), on which SYS::READ-FORM
94     ;; depends.
95    
96     ;; We could make do with either of the two methods below.
97    
98     (defmethod stream-read-char-no-hang ((s slime-input-stream))
99     (with-slots (buffer index) s
100     (when (< index (length buffer))
101     (prog1 (aref buffer index) (incf index)))))
102    
103     ;; This CLISP extension is what listen_char actually calls. The
104     ;; default method would call STREAM-READ-CHAR-NO-HANG, so it is a bit
105     ;; more efficient to define it directly.
106    
107     (defmethod stream-read-char-will-hang-p ((s slime-input-stream))
108     (with-slots (buffer index) s
109     (= index (length buffer))))
110    
111    
112     ;;;
113 heller 1.4 (defimplementation make-fn-streams (input-fn output-fn)
114 heller 1.3 (let* ((output (make-instance 'slime-output-stream
115     :output-fn output-fn))
116     (input (make-instance 'slime-input-stream
117     :input-fn input-fn
118     :output-stream output)))
119     (values input output)))

  ViewVC Help
Powered by ViewVC 1.1.5