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

Contents of /slime/swank-gray.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (hide annotations)
Thu Sep 22 20:15:11 2005 UTC (8 years, 7 months ago) by heller
Branch: MAIN
CVS Tags: SLIME-1-3
Branch point for: fsm
Changes since 1.8: +6 -1 lines
(stream-fresh-line): Define a method, so that Allegro passes our tests.
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     (last-flush-time :initform (get-internal-real-time))))
19 heller 1.1
20     (defmethod stream-write-char ((stream slime-output-stream) char)
21     (with-slots (buffer fill-pointer column) stream
22     (setf (schar buffer fill-pointer) char)
23     (incf fill-pointer)
24     (incf column)
25     (when (char= #\newline char)
26 heller 1.8 (setf column 0)
27     (force-output stream))
28 heller 1.1 (when (= fill-pointer (length buffer))
29 heller 1.8 (finish-output stream)))
30 heller 1.1 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 heller 1.8 (defmethod stream-finish-output ((stream slime-output-stream))
39     (with-slots (buffer fill-pointer output-fn last-flush-time) 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.8 (setf fill-pointer 0)))
44     (setf last-flush-time (get-internal-real-time)))
45     nil)
46    
47     (defmethod stream-force-output ((stream slime-output-stream))
48 heller 1.9 (with-slots (last-flush-time fill-pointer) stream
49 heller 1.8 (let ((now (get-internal-real-time)))
50     (when (> (/ (- now last-flush-time)
51     (coerce internal-time-units-per-second 'double-float))
52     0.2)
53     (finish-output stream))))
54 heller 1.1 nil)
55 heller 1.9
56     (defmethod stream-fresh-line ((stream slime-output-stream))
57     (with-slots (column) stream
58     (cond ((zerop column) nil)
59     (t (terpri stream) t))))
60 heller 1.1
61     (defclass slime-input-stream (fundamental-character-input-stream)
62 lgorrie 1.2 ((output-stream :initarg :output-stream)
63     (input-fn :initarg :input-fn)
64     (buffer :initform "") (index :initform 0)))
65 heller 1.1
66     (defmethod stream-read-char ((s slime-input-stream))
67 lgorrie 1.2 (with-slots (buffer index output-stream input-fn) s
68 heller 1.1 (when (= index (length buffer))
69 lgorrie 1.2 (when output-stream
70 heller 1.8 (finish-output output-stream))
71 heller 1.6 (let ((string (funcall input-fn)))
72     (cond ((zerop (length string))
73     (return-from stream-read-char :eof))
74     (t
75     (setf buffer string)
76     (setf index 0)))))
77 heller 1.1 (assert (plusp (length buffer)))
78     (prog1 (aref buffer index) (incf index))))
79    
80     (defmethod stream-listen ((s slime-input-stream))
81     (with-slots (buffer index) s
82     (< index (length buffer))))
83    
84     (defmethod stream-unread-char ((s slime-input-stream) char)
85     (with-slots (buffer index) s
86 heller 1.7 (decf index)
87     (cond ((eql (aref buffer index) char)
88     (setf (aref buffer index) char))
89     (t
90     (warn "stream-unread-char: ignoring ~S (expected ~S)"
91     char (aref buffer index)))))
92 heller 1.1 nil)
93    
94     (defmethod stream-clear-input ((s slime-input-stream))
95     (with-slots (buffer index) s
96     (setf buffer ""
97     index 0))
98     nil)
99    
100     (defmethod stream-line-column ((s slime-input-stream))
101     nil)
102    
103     (defmethod stream-line-length ((s slime-input-stream))
104     75)
105    
106 heller 1.3
107     ;;; CLISP extensions
108    
109     ;; We have to define an additional method for the sake of the C
110     ;; function listen_char (see src/stream.d), on which SYS::READ-FORM
111     ;; depends.
112    
113     ;; We could make do with either of the two methods below.
114    
115     (defmethod stream-read-char-no-hang ((s slime-input-stream))
116     (with-slots (buffer index) s
117     (when (< index (length buffer))
118     (prog1 (aref buffer index) (incf index)))))
119    
120     ;; This CLISP extension is what listen_char actually calls. The
121     ;; default method would call STREAM-READ-CHAR-NO-HANG, so it is a bit
122     ;; more efficient to define it directly.
123    
124     (defmethod stream-read-char-will-hang-p ((s slime-input-stream))
125     (with-slots (buffer index) s
126     (= index (length buffer))))
127    
128    
129     ;;;
130 heller 1.4 (defimplementation make-fn-streams (input-fn output-fn)
131 heller 1.3 (let* ((output (make-instance 'slime-output-stream
132     :output-fn output-fn))
133     (input (make-instance 'slime-input-stream
134     :input-fn input-fn
135     :output-stream output)))
136     (values input output)))

  ViewVC Help
Powered by ViewVC 1.1.5