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

Contents of /slime/swank-gray.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Tue Mar 9 19:35:36 2004 UTC (10 years, 1 month ago) by heller
Branch: MAIN
CVS Tags: SLIME-1-0-ALPHA, SLIME-0-14, SLIME-1-0-BETA, SLIME-1-0, SLIME-0-13, SLIME-0-12
Changes since 1.4: +0 -2 lines
Minor modifications.
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
11 (in-package :swank-backend)
12
13 (defclass slime-output-stream (fundamental-character-output-stream)
14 ((output-fn :initarg :output-fn)
15 (buffer :initform (make-string 512))
16 (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 (with-slots (buffer fill-pointer output-fn) stream
38 (let ((end fill-pointer))
39 (unless (zerop end)
40 (funcall output-fn (subseq buffer 0 end))
41 (setf fill-pointer 0))))
42 nil)
43
44 (defclass slime-input-stream (fundamental-character-input-stream)
45 ((output-stream :initarg :output-stream)
46 (input-fn :initarg :input-fn)
47 (buffer :initform "") (index :initform 0)))
48
49 (defmethod stream-read-char ((s slime-input-stream))
50 (with-slots (buffer index output-stream input-fn) s
51 (when (= index (length buffer))
52 (when output-stream
53 (force-output output-stream))
54 (setf buffer (funcall input-fn))
55 (setf index 0))
56 (assert (plusp (length buffer)))
57 (prog1 (aref buffer index) (incf index))))
58
59 (defmethod stream-listen ((s slime-input-stream))
60 (with-slots (buffer index) s
61 (< index (length buffer))))
62
63 (defmethod stream-unread-char ((s slime-input-stream) char)
64 (with-slots (buffer index) s
65 (setf (aref buffer (decf index)) char))
66 nil)
67
68 (defmethod stream-clear-input ((s slime-input-stream))
69 (with-slots (buffer index) s
70 (setf buffer ""
71 index 0))
72 nil)
73
74 (defmethod stream-line-column ((s slime-input-stream))
75 nil)
76
77 (defmethod stream-line-length ((s slime-input-stream))
78 75)
79
80
81 ;;; CLISP extensions
82
83 ;; We have to define an additional method for the sake of the C
84 ;; function listen_char (see src/stream.d), on which SYS::READ-FORM
85 ;; depends.
86
87 ;; We could make do with either of the two methods below.
88
89 (defmethod stream-read-char-no-hang ((s slime-input-stream))
90 (with-slots (buffer index) s
91 (when (< index (length buffer))
92 (prog1 (aref buffer index) (incf index)))))
93
94 ;; This CLISP extension is what listen_char actually calls. The
95 ;; default method would call STREAM-READ-CHAR-NO-HANG, so it is a bit
96 ;; more efficient to define it directly.
97
98 (defmethod stream-read-char-will-hang-p ((s slime-input-stream))
99 (with-slots (buffer index) s
100 (= index (length buffer))))
101
102
103 ;;;
104 (defimplementation make-fn-streams (input-fn output-fn)
105 (let* ((output (make-instance 'slime-output-stream
106 :output-fn output-fn))
107 (input (make-instance 'slime-input-stream
108 :input-fn input-fn
109 :output-stream output)))
110 (values input output)))

  ViewVC Help
Powered by ViewVC 1.1.5