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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Thu Aug 10 11:53:35 2006 UTC (7 years, 8 months ago) by heller
Branch: MAIN
Changes since 1.5: +2 -7 lines
swank-backend.lisp (definterface): Drop that incredibly unportable
CLOS stuff. Use plists and plain functions instead.  Update backends
accordingly.
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; swank-ecl.lisp --- SLIME backend for ECL.
4
5 ;;; Administrivia
6
7 (in-package :swank-backend)
8
9 (import-from :ext *gray-stream-symbols* :swank-backend)
10
11 (swank-backend::import-swank-mop-symbols :clos
12 '(:eql-specializer
13 :eql-specializer-object
14 :generic-function-declarations
15 :specializer-direct-methods
16 :compute-applicable-methods-using-classes))
17
18
19 ;;;; TCP Server
20
21 (require 'sockets)
22
23 (defun resolve-hostname (name)
24 (car (sb-bsd-sockets:host-ent-addresses
25 (sb-bsd-sockets:get-host-by-name name))))
26
27 (defimplementation create-socket (host port)
28 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
29 :type :stream
30 :protocol :tcp)))
31 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
32 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
33 (sb-bsd-sockets:socket-listen socket 5)
34 socket))
35
36 (defimplementation local-port (socket)
37 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
38
39 (defimplementation close-socket (socket)
40 (sb-bsd-sockets:socket-close socket))
41
42 (defimplementation accept-connection (socket
43 &key external-format
44 buffering timeout)
45 (declare (ignore buffering timeout))
46 (assert (eq external-format :iso-latin-1-unix))
47 (make-socket-io-stream (accept socket) external-format))
48
49 (defun make-socket-io-stream (socket external-format)
50 (sb-bsd-sockets:socket-make-stream socket
51 :output t
52 :input t
53 :element-type 'base-char))
54
55 (defun accept (socket)
56 "Like socket-accept, but retry on EAGAIN."
57 (loop (handler-case
58 (return (sb-bsd-sockets:socket-accept socket))
59 (sb-bsd-sockets:interrupted-error ()))))
60
61 (defimplementation preferred-communication-style ()
62 (values nil))
63
64
65 ;;;; Unix signals
66
67 (defimplementation getpid ()
68 (si:getpid))
69
70 #+nil
71 (defimplementation set-default-directory (directory)
72 (ext::chdir (namestring directory))
73 ;; Setting *default-pathname-defaults* to an absolute directory
74 ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
75 (setf *default-pathname-defaults* (ext::getcwd))
76 (default-directory))
77
78 #+nil
79 (defimplementation default-directory ()
80 (namestring (ext:getcwd)))
81
82 (defimplementation quit-lisp ()
83 (ext:quit))
84
85
86 ;;;; Compilation
87
88 (defvar *buffer-name* nil)
89 (defvar *buffer-start-position*)
90 (defvar *buffer-string*)
91 (defvar *compile-filename*)
92
93 (defun signal-compiler-condition (&rest args)
94 (signal (apply #'make-condition 'compiler-condition args)))
95
96 (defun handle-compiler-warning (condition)
97 (signal-compiler-condition
98 :original-condition condition
99 :message (format nil "~A" condition)
100 :severity :warning
101 :location
102 (if *buffer-name*
103 (make-location (list :buffer *buffer-name*)
104 (list :position *buffer-start-position*))
105 ;; ;; compiler::*current-form*
106 ;; (if compiler::*current-function*
107 ;; (make-location (list :file *compile-filename*)
108 ;; (list :function-name
109 ;; (symbol-name
110 ;; (slot-value compiler::*current-function*
111 ;; 'compiler::name))))
112 (list :error "No location found.")
113 ;; )
114 )))
115
116 (defimplementation call-with-compilation-hooks (function)
117 (handler-bind ((warning #'handle-compiler-warning))
118 (funcall function)))
119
120 (defimplementation swank-compile-file (*compile-filename* load-p
121 &optional external-format)
122 (declare (ignore external-format))
123 (with-compilation-hooks ()
124 (let ((*buffer-name* nil))
125 (multiple-value-bind (fn warn fail)
126 (compile-file *compile-filename*)
127 (when load-p (unless fail (load fn)))))))
128
129 (defimplementation swank-compile-string (string &key buffer position directory)
130 (declare (ignore directory))
131 (with-compilation-hooks ()
132 (let ((*buffer-name* buffer)
133 (*buffer-start-position* position)
134 (*buffer-string* string))
135 (with-input-from-string (s string)
136 (compile-from-stream s :load t)))))
137
138 (defun compile-from-stream (stream &rest args)
139 (let ((file (si::mkstemp "TMP:ECLXXXXXX")))
140 (with-open-file (s file :direction :output :if-exists :overwrite)
141 (do ((line (read-line stream nil) (read-line stream nil)))
142 (line)
143 (write-line line s)))
144 (unwind-protect
145 (apply #'compile-file file args)
146 (delete-file file))))
147
148
149 ;;;; Documentation
150
151 (defimplementation arglist (name)
152 (or (functionp name) (setf name (symbol-function name)))
153 (if (functionp name)
154 (typecase name
155 (generic-function
156 (clos::generic-function-lambda-list name))
157 (function
158 (let ((fle (function-lambda-expression name)))
159 (case (car fle)
160 (si:lambda-block (caddr fle))
161 (t :not-available)))))
162 :not-available))
163
164 (defimplementation function-name (f)
165 (si:compiled-function-name f))
166
167 (defimplementation macroexpand-all (form)
168 ;;; FIXME! This is not the same as a recursive macroexpansion!
169 (macroexpand form))
170
171 (defimplementation describe-symbol-for-emacs (symbol)
172 (let ((result '()))
173 (dolist (type '(:VARIABLE :FUNCTION :CLASS))
174 (let ((doc (describe-definition symbol type)))
175 (when doc
176 (setf result (list* type doc result)))))
177 result))
178
179 (defimplementation describe-definition (name type)
180 (case type
181 (:variable (documentation name 'variable))
182 (:function (documentation name 'function))
183 (:class (documentation name 'class))
184 (t nil)))
185
186 ;;; Debugging
187
188 (import
189 '(si::*ihs-top*
190 si::*ihs-current*
191 si::*ihs-base*
192 si::*frs-base*
193 si::*frs-top*
194 si::*tpl-commands*
195 si::*tpl-level*
196 si::frs-top
197 si::ihs-top
198 si::sch-frs-base
199 si::set-break-env
200 si::set-current-ihs
201 si::tpl-commands))
202
203 (defimplementation call-with-debugging-environment (debugger-loop-fn)
204 (declare (type function debugger-loop-fn))
205 (let* ((*tpl-commands* si::tpl-commands)
206 (*ihs-top* (ihs-top 'call-with-debugging-environment))
207 (*ihs-current* *ihs-top*)
208 (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
209 (*frs-top* (frs-top))
210 (*read-suppress* nil)
211 (*tpl-level* (1+ *tpl-level*)))
212 (set-break-env)
213 (set-current-ihs)
214 (funcall debugger-loop-fn)))
215
216 ;; (defimplementation call-with-debugger-hook (hook fun)
217 ;; (let ((*debugger-hook* hook))
218 ;; (funcall fun)))
219
220 (defun nth-frame (n)
221 (cond ((>= n *ihs-top* ) nil)
222 (t (- *ihs-top* n))))
223
224 (defimplementation compute-backtrace (start end)
225 (loop for i from start below end
226 for f = (nth-frame i)
227 while f
228 collect f))
229
230 (defimplementation print-frame (frame stream)
231 (format stream "~A" (si::ihs-fname frame)))
232
233 ;;;; Inspector
234
235 (defclass ecl-inspector (inspector)
236 ())
237
238 (defimplementation make-default-inspector ()
239 (make-instance 'ecl-inspector))
240
241 ;;;; Definitions
242
243 (defimplementation find-definitions (name) nil)

  ViewVC Help
Powered by ViewVC 1.1.5