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

Diff of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.15 by heller, Sat Nov 1 15:43:05 2003 UTC revision 1.16 by heller, Sun Nov 2 23:08:03 2003 UTC
# Line 19  Line 19 
19  ;;; TCP Server.  ;;; TCP Server.
20    
21  (defstruct (slime-output-stream  (defstruct (slime-output-stream
22              (:include lisp::string-output-stream               (:include lisp::lisp-stream
23                        (lisp::misc #'slime-out-misc)))                         (lisp::misc #'sos/misc)
24    (last-charpos 0 :type kernel:index))                         (lisp::out #'sos/out)
25                           (lisp::sout #'sos/sout))
26  (defun slime-out-misc (stream operation &optional arg1 arg2)               (:conc-name sos.))
27      (buffer (make-string 512) :type string)
28      (index 0 :type kernel:index)
29      (column 0 :type kernel:index))
30    
31    (defun sos/out (stream char)
32      (let ((buffer (sos.buffer stream))
33            (index (sos.index stream)))
34        (setf (schar buffer index) char)
35        (setf (sos.index stream) (1+ index))
36        (incf (sos.column stream))
37        (cond ((char= #\newline char)
38               (force-output stream)
39               (setf (sos.column stream) 0))
40              ((= index (length buffer))
41               (force-output stream))))
42      char)
43    
44    (defun sos/sout (stream string start end)
45      (loop for i from start below end
46            do (sos/out stream (aref string i))))
47    
48    (defun sos/misc (stream operation &optional arg1 arg2)
49      (declare (ignore arg1 arg2))
50    (case operation    (case operation
51      (:force-output      (:force-output
52       (unless (zerop (lisp::string-output-stream-index stream))       (let ((end (sos.index stream)))
53         (setf (slime-output-stream-last-charpos stream)         (unless (zerop end)
54               (slime-out-misc stream :charpos))           (send-to-emacs `(:read-output ,(subseq (sos.buffer stream) 0 end)))
55         (send-to-emacs `(:read-output ,(get-output-stream-string stream)))))           (setf (sos.index stream) 0))))
56        (:charpos (sos.column stream))
57        (:line-length 75)
58      (:file-position nil)      (:file-position nil)
59      (:charpos      (:element-type 'base-char)
60       (do ((index (1- (the fixnum (lisp::string-output-stream-index stream)))      (:get-command nil)
61                   (1- index))      (t (format *terminal-io* "~&~Astream: ~S~%" stream operation))))
           (count 0 (1+ count))  
           (string (lisp::string-output-stream-string stream)))  
          ((< index 0) (+ count (slime-output-stream-last-charpos stream)))  
        (declare (simple-string string)  
                 (fixnum index count))  
        (if (char= (schar string index) #\newline)  
            (return count))))  
     (t (lisp::string-out-misc stream operation arg1 arg2))))  
62    
63  (defstruct (slime-input-stream  (defstruct (slime-input-stream
64               (:include sys:lisp-stream               (:include string-stream
65                         (lisp::in #'slime-input-stream-read-char)                         (lisp::in #'sis/in)
66                         (lisp::misc #'slime-input-stream-misc-ops)))                         (lisp::misc #'sis/misc))
67    (buffered-char nil :type (or null character)))               (:conc-name sis.))
68      (buffer "" :type string)
69  (defun slime-input-stream-read-char (stream &optional eoferr eofval)    (index 0 :type kernel:index))
70    (declare (ignore eoferr eofval))  
71    (let ((c (slime-input-stream-buffered-char stream)))  (defun sis/in (stream eof-errorp eof-value)
72      (cond (c (setf (slime-input-stream-buffered-char stream) nil) c)    (let ((index (sis.index stream))
73            (t (slime-read-char)))))          (buffer (sis.buffer stream)))
74        (when (= index (length buffer))
75          (setf buffer (slime-read-string))
76          (setf (sis.buffer stream) buffer)
77          (setf index 0))
78        (prog1 (aref buffer index)
79          (setf (sis.index stream) (1+ index)))))
80    
81  (defun slime-input-stream-misc-ops (stream operation &optional arg1 arg2)  (defun sis/misc (stream operation &optional arg1 arg2)
82    (declare (ignore arg2))    (declare (ignore arg2))
83    (ecase operation    (ecase operation
     (:unread  
      (assert (not (slime-input-stream-buffered-char stream)))  
      (setf (slime-input-stream-buffered-char stream) arg1)  
      nil)  
     (:listen nil)  
     (:clear-input (setf (slime-input-stream-buffered-char stream) nil))  
84      (:file-position nil)      (:file-position nil)
85      (:charpos nil)))      (:file-length nil)
86        (:unread (setf (aref (sis.buffer stream)
87                             (decf (sis.index stream)))
88                       arg1))
89        (:clear-input (setf (sis.index stream) 0
90                            (sis.buffer stream) ""))
91        (:listen (< (sis.index stream) (length (sis.buffer stream))))
92        (:charpos nil)
93        (:line-length nil)
94        (:get-command nil)
95        (:element-type 'base-char)))
96    
97    
98    ;; (eval-when (:load-toplevel :compile-toplevel :execute)
99    ;;   (require :gray-streams))
100    ;;
101    ;; (defclass slime-input-stream (ext:fundamental-character-input-stream)
102    ;;   ((buffer :initform "") (index :initform 0)))
103    ;;
104    ;; (defmethod ext:stream-read-char ((s slime-input-stream))
105    ;;   (with-slots (buffer index) s
106    ;;     (when (= index (length buffer))
107    ;;       (setf buffer (slime-read-string))
108    ;;       (setf index 0))
109    ;;     (assert (plusp (length buffer)))
110    ;;     (prog1 (aref buffer index) (incf index))))
111    ;;
112    ;; (defmethod ext:stream-listen ((s slime-input-stream))
113    ;;   (with-slots (buffer index) s
114    ;;     (< index (length buffer))))
115    ;;
116    ;; (defmethod ext:stream-unread-char ((s slime-input-stream) char)
117    ;;   (with-slots (buffer index) s
118    ;;     (setf (aref buffer (decf index)) char))
119    ;;   nil)
120    ;;
121    ;; (defmethod ext:stream-clear-input ((s slime-input-stream))
122    ;;   (with-slots (buffer index) s
123    ;;     (setf buffer ""
124    ;;           index 0))
125    ;;   nil)
126    ;;
127    ;; (defmethod ext:stream-line-column ((s slime-input-stream))
128    ;;   nil)
129    ;;
130    ;; (defmethod ext:stream-line-length ((s slime-input-stream))
131    ;;   75)
132    ;;
133    ;; (defun make-slime-input-stream ()
134    ;;   (make-instance 'slime-input-stream))
135    
136    
137    
138  (defun create-swank-server (port &key reuse-address (address "localhost"))  (defun create-swank-server (port &key reuse-address (address "localhost"))
139    "Create a SWANK TCP server."    "Create a SWANK TCP server."
# Line 107  The request is read from the socket as a Line 175  The request is read from the socket as a
175            (when *swank-debug-p*            (when *swank-debug-p*
176              (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))              (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))
177            (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*))            (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*))
178            (close *emacs-io*))))))            (close *emacs-io*)))))
179      (sys:scrub-control-stack))
180    
181  ;;;  ;;;
182    
# Line 636  format suitable for Emacs." Line 705  format suitable for Emacs."
705            (let ((*print-pretty* nil))            (let ((*print-pretty* nil))
706              (debug::print-frame-call frame :verbosity 1 :number t)))))              (debug::print-frame-call frame :verbosity 1 :number t)))))
707    
 (defun backtrace-length ()  
   "Return the number of frames on the stack."  
   (do ((frame *sldb-stack-top* (di:frame-down frame))  
        (i 0 (1+ i)))  
       ((not frame) i)))  
   
708  (defun compute-backtrace (start end)  (defun compute-backtrace (start end)
709    "Return a list of frames starting with frame number START and    "Return a list of frames starting with frame number START and
710  continuing to frame number END or, if END is nil, the last frame on the  continuing to frame number END or, if END is nil, the last frame on the
# Line 658  stack." Line 721  stack."
721  (defslimefun debugger-info-for-emacs (start end)  (defslimefun debugger-info-for-emacs (start end)
722    (list (format-condition-for-emacs)    (list (format-condition-for-emacs)
723          (format-restarts-for-emacs)          (format-restarts-for-emacs)
         (backtrace-length)  
724          (backtrace-for-emacs start end)))          (backtrace-for-emacs start end)))
725    
726  (defun code-location-source-path (code-location)  (defun code-location-source-path (code-location)

Legend:
Removed from v.1.15  
changed lines
  Added in v.1.16

  ViewVC Help
Powered by ViewVC 1.1.5