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

Contents of /slime/swank-gray.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Tue Jan 13 18:21:48 2004 UTC (10 years, 3 months ago) by heller
Branch: MAIN
CVS Tags: STATELESS-EMACS, SLIME-0-11
Branch point for: stateless-emacs, package-split
Changes since 1.2: +32 -1 lines
(make-fn-streams): New function.

(stream-read-char-no-hang, stream-read-char-will-hang-p): Moved to
here from swank-clisp.lisp.
1 heller 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2     ;;;
3     ;;; swank-gray.lisp --- Gray stream based IO redirection.
4     ;;;
5     ;;; Created 2003, Helmut Eller
6     ;;;
7     ;;; This code has been placed in the Public Domain. All warranties
8     ;;; are disclaimed.
9     ;;;
10 heller 1.3 ;;; $Id: swank-gray.lisp,v 1.3 2004/01/13 18:21:48 heller Exp $
11 heller 1.1 ;;;
12    
13     (in-package :swank)
14    
15     (defclass slime-output-stream (fundamental-character-output-stream)
16 lgorrie 1.2 ((output-fn :initarg :output-fn)
17     (buffer :initform (make-string 512))
18 heller 1.1 (fill-pointer :initform 0)
19     (column :initform 0)))
20    
21     (defmethod stream-write-char ((stream slime-output-stream) char)
22     (with-slots (buffer fill-pointer column) stream
23     (setf (schar buffer fill-pointer) char)
24     (incf fill-pointer)
25     (incf column)
26     (when (char= #\newline char)
27     (setf column 0))
28     (when (= fill-pointer (length buffer))
29     (force-output stream)))
30     char)
31    
32     (defmethod stream-line-column ((stream slime-output-stream))
33     (slot-value stream 'column))
34    
35     (defmethod stream-line-length ((stream slime-output-stream))
36     75)
37    
38     (defmethod stream-force-output ((stream slime-output-stream))
39 lgorrie 1.2 (with-slots (buffer fill-pointer output-fn) stream
40 heller 1.1 (let ((end fill-pointer))
41     (unless (zerop end)
42 lgorrie 1.2 (funcall output-fn (subseq buffer 0 end))
43 heller 1.1 (setf fill-pointer 0))))
44     nil)
45    
46     (defclass slime-input-stream (fundamental-character-input-stream)
47 lgorrie 1.2 ((output-stream :initarg :output-stream)
48     (input-fn :initarg :input-fn)
49     (buffer :initform "") (index :initform 0)))
50 heller 1.1
51     (defmethod stream-read-char ((s slime-input-stream))
52 lgorrie 1.2 (with-slots (buffer index output-stream input-fn) s
53 heller 1.1 (when (= index (length buffer))
54 lgorrie 1.2 (when output-stream
55     (force-output output-stream))
56     (setf buffer (funcall input-fn))
57 heller 1.1 (setf index 0))
58     (assert (plusp (length buffer)))
59     (prog1 (aref buffer index) (incf index))))
60    
61     (defmethod stream-listen ((s slime-input-stream))
62     (with-slots (buffer index) s
63     (< index (length buffer))))
64    
65     (defmethod stream-unread-char ((s slime-input-stream) char)
66     (with-slots (buffer index) s
67     (setf (aref buffer (decf index)) char))
68     nil)
69    
70     (defmethod stream-clear-input ((s slime-input-stream))
71     (with-slots (buffer index) s
72     (setf buffer ""
73     index 0))
74     nil)
75    
76     (defmethod stream-line-column ((s slime-input-stream))
77     nil)
78    
79     (defmethod stream-line-length ((s slime-input-stream))
80     75)
81    
82 heller 1.3
83     ;;; CLISP extensions
84    
85     ;; We have to define an additional method for the sake of the C
86     ;; function listen_char (see src/stream.d), on which SYS::READ-FORM
87     ;; depends.
88    
89     ;; We could make do with either of the two methods below.
90    
91     (defmethod stream-read-char-no-hang ((s slime-input-stream))
92     (with-slots (buffer index) s
93     (when (< index (length buffer))
94     (prog1 (aref buffer index) (incf index)))))
95    
96     ;; This CLISP extension is what listen_char actually calls. The
97     ;; default method would call STREAM-READ-CHAR-NO-HANG, so it is a bit
98     ;; more efficient to define it directly.
99    
100     (defmethod stream-read-char-will-hang-p ((s slime-input-stream))
101     (with-slots (buffer index) s
102     (= index (length buffer))))
103    
104    
105     ;;;
106     (defmethod make-fn-streams (input-fn output-fn)
107     (let* ((output (make-instance 'slime-output-stream
108     :output-fn output-fn))
109     (input (make-instance 'slime-input-stream
110     :input-fn input-fn
111     :output-stream output)))
112     (values input output)))

  ViewVC Help
Powered by ViewVC 1.1.5