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

Contents of /slime/swank-gray.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3.4.1 - (show annotations)
Tue Mar 9 08:57:25 2004 UTC (10 years, 1 month ago) by heller
Branch: package-split
Changes since 1.3: +3 -3 lines
Implement changed backend interface and remove references to front end symbols.
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 ;;; $Id: swank-gray.lisp,v 1.3.4.1 2004/03/09 08:57:25 heller Exp $
11 ;;;
12
13 (in-package :swank-backend)
14
15 (defclass slime-output-stream (fundamental-character-output-stream)
16 ((output-fn :initarg :output-fn)
17 (buffer :initform (make-string 512))
18 (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 (with-slots (buffer fill-pointer output-fn) stream
40 (let ((end fill-pointer))
41 (unless (zerop end)
42 (funcall output-fn (subseq buffer 0 end))
43 (setf fill-pointer 0))))
44 nil)
45
46 (defclass slime-input-stream (fundamental-character-input-stream)
47 ((output-stream :initarg :output-stream)
48 (input-fn :initarg :input-fn)
49 (buffer :initform "") (index :initform 0)))
50
51 (defmethod stream-read-char ((s slime-input-stream))
52 (with-slots (buffer index output-stream input-fn) s
53 (when (= index (length buffer))
54 (when output-stream
55 (force-output output-stream))
56 (setf buffer (funcall input-fn))
57 (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
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 (defimplementation 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