Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 733 lines (608 sloc) 24.914 kb
5fb5464a »
2006-11-19 (find-external-format, guess-external-format): New.
1 ;;;; -*- indent-tabs-mode: nil -*-
f33058f1 »
2005-08-03 Initial port to ECL
2 ;;;
3 ;;; swank-ecl.lisp --- SLIME backend for ECL.
5fb5464a »
2006-11-19 (find-external-format, guess-external-format): New.
4 ;;;
5 ;;; This code has been placed in the Public Domain. All warranties
6 ;;; are disclaimed.
7 ;;;
f33058f1 »
2005-08-03 Initial port to ECL
8
9 ;;; Administrivia
10
11 (in-package :swank-backend)
12
6457beb9 »
2010-02-16 Pimp my swank.
13 (eval-when (:compile-toplevel :load-toplevel :execute)
14 (let ((version (find-symbol "+ECL-VERSION-NUMBER+" :EXT)))
15 (when (or (not version) (< (symbol-value version) 100201))
16 (error "~&IMPORTANT:~% ~
17 The version of ECL you're using (~A) is too old.~% ~
18 Please upgrade to at least 10.2.1.~% ~
19 Sorry for the inconvenience.~%~%"
20 (lisp-implementation-version)))))
21
4d214b67 »
2010-02-20 More work on ECL's swank-backend.
22 ;; Hard dependencies.
23 (eval-when (:compile-toplevel :load-toplevel :execute)
24 (require 'sockets))
25
26 ;; Soft dependencies.
27 (eval-when (:compile-toplevel :load-toplevel :execute)
28 (when (probe-file "sys:profile.fas")
29 (require :profile)
30 (pushnew :profile *features*))
31 (when (probe-file "sys:serve-event.fas")
32 (require :serve-event)
33 (pushnew :serve-event *features*)))
34
670648a5 »
2009-06-12 Support new environment changes in recent ECL/CVS
35 (declaim (optimize (debug 3)))
36
6457beb9 »
2010-02-16 Pimp my swank.
37 ;;; Swank-mop
98a99bda »
2008-04-24 basic/simple implementation of find-definitions
38
10425c02 »
2008-08-27 * swank-ecl.lisp: Add :load-toplevel and :execute to EVAL-WHENs to
39 (eval-when (:compile-toplevel :load-toplevel :execute)
6457beb9 »
2010-02-16 Pimp my swank.
40 (import-from :gray *gray-stream-symbols* :swank-backend)
fdfd77b0 »
2009-11-13 * swank-ecl.lisp (swank-mop:compute-applicable-methods-using-classes):
41
6457beb9 »
2010-02-16 Pimp my swank.
42 (import-swank-mop-symbols :clos
fdfd77b0 »
2009-11-13 * swank-ecl.lisp (swank-mop:compute-applicable-methods-using-classes):
43 '(:eql-specializer
44 :eql-specializer-object
45 :generic-function-declarations
46 :specializer-direct-methods
47 :compute-applicable-methods-using-classes)))
48
f33058f1 »
2005-08-03 Initial port to ECL
49
50 ;;;; TCP Server
51
8e5db041 »
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
52 (defimplementation preferred-communication-style ()
53 ;; While ECL does provide threads, some parts of it are not
54 ;; thread-safe (2010-02-23), including the compiler and CLOS.
55 nil
56 ;; ECL on Windows does not provide condition-variables
57 ;; (or #+(and threads (not windows)) :spawn
58 ;; nil)
59 )
60
f33058f1 »
2005-08-03 Initial port to ECL
61 (defun resolve-hostname (name)
62 (car (sb-bsd-sockets:host-ent-addresses
63 (sb-bsd-sockets:get-host-by-name name))))
64
65 (defimplementation create-socket (host port)
66 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
67 :type :stream
68 :protocol :tcp)))
69 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
70 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
71 (sb-bsd-sockets:socket-listen socket 5)
72 socket))
73
74 (defimplementation local-port (socket)
75 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
76
77 (defimplementation close-socket (socket)
78 (sb-bsd-sockets:socket-close socket))
79
80 (defimplementation accept-connection (socket
e51892e9 »
2006-08-10 swank-backend.lisp (definterface): Drop that incredibly unportable
81 &key external-format
d4ac7e72 »
2006-03-22 * Improve the robustness of connection establishment.
82 buffering timeout)
4d214b67 »
2010-02-20 More work on ECL's swank-backend.
83 (declare (ignore timeout))
6457beb9 »
2010-02-16 Pimp my swank.
84 (sb-bsd-sockets:socket-make-stream (accept socket)
f33058f1 »
2005-08-03 Initial port to ECL
85 :output t
86 :input t
4d214b67 »
2010-02-20 More work on ECL's swank-backend.
87 :buffering buffering
88 :external-format external-format))
f33058f1 »
2005-08-03 Initial port to ECL
89 (defun accept (socket)
90 "Like socket-accept, but retry on EAGAIN."
91 (loop (handler-case
92 (return (sb-bsd-sockets:socket-accept socket))
93 (sb-bsd-sockets:interrupted-error ()))))
94
8e5db041 »
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
95 (defimplementation socket-fd (socket)
96 (etypecase socket
97 (fixnum socket)
98 (two-way-stream (socket-fd (two-way-stream-input-stream socket)))
99 (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
100 (file-stream (si:file-stream-fd socket))))
f33058f1 »
2005-08-03 Initial port to ECL
101
d2530653 »
2009-07-06 * swank-ecl.lisp (find-external-format): Copied from
102 (defvar *external-format-to-coding-system*
4d214b67 »
2010-02-20 More work on ECL's swank-backend.
103 '((:latin-1
d2530653 »
2009-07-06 * swank-ecl.lisp (find-external-format): Copied from
104 "latin-1" "latin-1-unix" "iso-latin-1-unix"
105 "iso-8859-1" "iso-8859-1-unix")
106 (:utf-8 "utf-8" "utf-8-unix")))
107
4d214b67 »
2010-02-20 More work on ECL's swank-backend.
108 (defun external-format (coding-system)
109 (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
110 *external-format-to-coding-system*))
111 (find coding-system (ext:all-encodings) :test #'string-equal)))
112
d2530653 »
2009-07-06 * swank-ecl.lisp (find-external-format): Copied from
113 (defimplementation find-external-format (coding-system)
4d214b67 »
2010-02-20 More work on ECL's swank-backend.
114 #+unicode (external-format coding-system)
115 ;; Without unicode support, ECL uses the one-byte encoding of the
116 ;; underlying OS, and will barf on anything except :DEFAULT. We
117 ;; return NIL here for known multibyte encodings, so
118 ;; SWANK:CREATE-SERVER will barf.
119 #-unicode (let ((xf (external-format coding-system)))
120 (if (member xf '(:utf-8))
121 nil
122 :default)))
d2530653 »
2009-07-06 * swank-ecl.lisp (find-external-format): Copied from
123
f33058f1 »
2005-08-03 Initial port to ECL
124
4d214b67 »
2010-02-20 More work on ECL's swank-backend.
125 ;;;; Unix Integration
f33058f1 »
2005-08-03 Initial port to ECL
126
6457beb9 »
2010-02-16 Pimp my swank.
127 (defvar *original-sigint-handler* #'si:terminal-interrupt)
128
7be8fd7b »
2008-08-11 Improve interrupt safety for single-threaded lisps.
129 (defimplementation install-sigint-handler (handler)
6457beb9 »
2010-02-16 Pimp my swank.
130 (declare (function handler))
7be8fd7b »
2008-08-11 Improve interrupt safety for single-threaded lisps.
131 (let ((old-handler (symbol-function 'si:terminal-interrupt)))
132 (setf (symbol-function 'si:terminal-interrupt)
6457beb9 »
2010-02-16 Pimp my swank.
133 (if (eq handler *original-sigint-handler*)
134 handler
7be8fd7b »
2008-08-11 Improve interrupt safety for single-threaded lisps.
135 (lambda (&rest args)
136 (declare (ignore args))
137 (funcall handler)
138 (continue))))
6457beb9 »
2010-02-16 Pimp my swank.
139 old-handler))
7be8fd7b »
2008-08-11 Improve interrupt safety for single-threaded lisps.
140
f33058f1 »
2005-08-03 Initial port to ECL
141 (defimplementation getpid ()
142 (si:getpid))
143
144 (defimplementation set-default-directory (directory)
6457beb9 »
2010-02-16 Pimp my swank.
145 (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*.
f33058f1 »
2005-08-03 Initial port to ECL
146 (default-directory))
147
148 (defimplementation default-directory ()
149 (namestring (ext:getcwd)))
150
151 (defimplementation quit-lisp ()
152 (ext:quit))
153
154
6457beb9 »
2010-02-16 Pimp my swank.
155
8e5db041 »
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
156 ;;; Instead of busy waiting with communication-style NIL, use select()
157 ;;; on the sockets' streams.
6457beb9 »
2010-02-16 Pimp my swank.
158 #+serve-event
159 (progn
8e5db041 »
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
160 (defun poll-streams (streams timeout)
161 (let* ((serve-event::*descriptor-handlers*
162 (copy-list serve-event::*descriptor-handlers*))
163 (active-fds '())
164 (fd-stream-alist
165 (loop for s in streams
166 for fd = (socket-fd s)
167 collect (cons (socket-fd s) s)
168 do (serve-event:add-fd-handler fd :input
169 #'(lambda (fd)
170 (push fd active-fds))))))
171 (serve-event:serve-event timeout)
172 (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist)))))
173
174 (defimplementation wait-for-input (streams &optional timeout)
175 (assert (member timeout '(nil t)))
176 (loop
177 (cond ((check-slime-interrupts) (return :interrupt))
178 (timeout (return (poll-streams streams 0)))
179 (t
4e64b26a »
2010-02-23 * swank-backend.lisp (when-let): New macro. For backends and
180 (when-let (ready (poll-streams streams 0.2))
181 (return ready))))))
6457beb9 »
2010-02-16 Pimp my swank.
182
183 ) ; #+serve-event (progn ...
184
185
f33058f1 »
2005-08-03 Initial port to ECL
186 ;;;; Compilation
187
188 (defvar *buffer-name* nil)
189 (defvar *buffer-start-position*)
190
191 (defun signal-compiler-condition (&rest args)
192 (signal (apply #'make-condition 'compiler-condition args)))
193
6457beb9 »
2010-02-16 Pimp my swank.
194 (defun handle-compiler-message (condition)
195 ;; ECL emits lots of noise in compiler-notes, like "Invoking
196 ;; external command".
197 (unless (typep condition 'c::compiler-note)
198 (signal-compiler-condition
199 :original-condition condition
4d214b67 »
2010-02-20 More work on ECL's swank-backend.
200 :message (princ-to-string condition)
6457beb9 »
2010-02-16 Pimp my swank.
201 :severity (etypecase condition
202 (c:compiler-fatal-error :error)
4d214b67 »
2010-02-20 More work on ECL's swank-backend.
203 (c:compiler-error :error)
204 (error :error)
205 (style-warning :style-warning)
206 (warning :warning))
6457beb9 »
2010-02-16 Pimp my swank.
207 :location (condition-location condition))))
208
4d214b67 »
2010-02-20 More work on ECL's swank-backend.
209 (defun make-file-location (file file-position)
210 ;; File positions in CL start at 0, but Emacs' buffer positions
3d76a5c0 »
2010-02-22 Make M-. be able to jump right into the C source for ECL.
211 ;; start at 1. We specify (:ALIGN T) because the positions comming
212 ;; from ECL point at right after the toplevel form appearing before
213 ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case.
4d214b67 »
2010-02-20 More work on ECL's swank-backend.
214 (make-location `(:file ,(namestring file))
215 `(:position ,(1+ file-position))
216 `(:align t)))
217
218 (defun make-buffer-location (buffer-name start-position offset)
219 (make-location `(:buffer ,buffer-name)
220 `(:offset ,start-position ,offset)
221 `(:align t)))
222
6457beb9 »
2010-02-16 Pimp my swank.
223 (defun condition-location (condition)
224 (let ((file (c:compiler-message-file condition))
225 (position (c:compiler-message-file-position condition)))
226 (if (and position (not (minusp position)))
227 (if *buffer-name*
8e5db041 »
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
228 (make-buffer-location *buffer-name*
229 *buffer-start-position*
230 position)
4d214b67 »
2010-02-20 More work on ECL's swank-backend.
231 (make-file-location file position))
6457beb9 »
2010-02-16 Pimp my swank.
232 (make-error-location "No location found."))))
f33058f1 »
2005-08-03 Initial port to ECL
233
234 (defimplementation call-with-compilation-hooks (function)
6457beb9 »
2010-02-16 Pimp my swank.
235 (handler-bind ((c:compiler-message #'handle-compiler-message))
f33058f1 »
2005-08-03 Initial port to ECL
236 (funcall function)))
237
f761f28f »
2009-01-10 * swank-backend.lisp (swank-compile-file): Take output-file as
238 (defimplementation swank-compile-file (input-file output-file
20bed409 »
2010-03-02 * slime.el (slime-compile-and-load-file): Accept C-u arguments for
239 load-p external-format
240 &key policy)
241 (declare (ignore policy))
f33058f1 »
2005-08-03 Initial port to ECL
242 (with-compilation-hooks ()
4d214b67 »
2010-02-20 More work on ECL's swank-backend.
243 (compile-file input-file :output-file output-file
244 :load load-p
245 :external-format external-format)))
f33058f1 »
2005-08-03 Initial port to ECL
246
4314d2ea »
2009-01-08 * swank-backend.lisp (swank-compile-string): Pass the
247 (defimplementation swank-compile-string (string &key buffer position filename
4d214b67 »
2010-02-20 More work on ECL's swank-backend.
248 policy)
4314d2ea »
2009-01-08 * swank-backend.lisp (swank-compile-string): Pass the
249 (declare (ignore filename policy))
f33058f1 »
2005-08-03 Initial port to ECL
250 (with-compilation-hooks ()
4d214b67 »
2010-02-20 More work on ECL's swank-backend.
251 (let ((*buffer-name* buffer) ; for compilation hooks
6457beb9 »
2010-02-16 Pimp my swank.
252 (*buffer-start-position* position))
3d76a5c0 »
2010-02-22 Make M-. be able to jump right into the C source for ECL.
253 (let ((file (si:mkstemp "TMP:ECL-SWANK-"))
254 (fasl-file)
255 (warnings-p)
256 (failure-p))
4d214b67 »
2010-02-20 More work on ECL's swank-backend.
257 (unwind-protect
258 (with-open-file (file-stream file :direction :output
259 :if-exists :supersede)
260 (write-string string file-stream)
261 (finish-output file-stream)
3d76a5c0 »
2010-02-22 Make M-. be able to jump right into the C source for ECL.
262 (multiple-value-setq (fasl-file warnings-p failure-p)
263 (compile-file file :load t)))
264 (when (probe-file file)
265 (delete-file file))
266 (when fasl-file
267 (delete-file fasl-file)))
268 (not failure-p)))))
f33058f1 »
2005-08-03 Initial port to ECL
269
270 ;;;; Documentation
271
272 (defimplementation arglist (name)
8e5db041 »
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
273 (multiple-value-bind (arglist foundp)
4e64b26a »
2010-02-23 * swank-backend.lisp (when-let): New macro. For backends and
274 (ext:function-lambda-list name)
8e5db041 »
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
275 (if foundp arglist :not-available)))
f33058f1 »
2005-08-03 Initial port to ECL
276
e51892e9 »
2006-08-10 swank-backend.lisp (definterface): Drop that incredibly unportable
277 (defimplementation function-name (f)
076253cd »
2009-11-13 * swank-ecl.lisp (function-name): Use clos:generic-function-name
278 (typecase f
279 (generic-function (clos:generic-function-name f))
280 (function (si:compiled-function-name f))))
f33058f1 »
2005-08-03 Initial port to ECL
281
6457beb9 »
2010-02-16 Pimp my swank.
282 ;; FIXME
283 ;; (defimplementation macroexpand-all (form))
f33058f1 »
2005-08-03 Initial port to ECL
284
285 (defimplementation describe-symbol-for-emacs (symbol)
286 (let ((result '()))
287 (dolist (type '(:VARIABLE :FUNCTION :CLASS))
4e64b26a »
2010-02-23 * swank-backend.lisp (when-let): New macro. For backends and
288 (when-let (doc (describe-definition symbol type))
289 (setf result (list* type doc result))))
f33058f1 »
2005-08-03 Initial port to ECL
290 result))
291
292 (defimplementation describe-definition (name type)
293 (case type
294 (:variable (documentation name 'variable))
295 (:function (documentation name 'function))
296 (:class (documentation name 'class))
297 (t nil)))
298
8e5db041 »
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
299
f33058f1 »
2005-08-03 Initial port to ECL
300 ;;; Debugging
301
10425c02 »
2008-08-27 * swank-ecl.lisp: Add :load-toplevel and :execute to EVAL-WHENs to
302 (eval-when (:compile-toplevel :load-toplevel :execute)
990fceaf »
2008-08-22 * contrib/swank-listener-hooks.lisp: Add missing IN-PACKAGE.
303 (import
304 '(si::*break-env*
305 si::*ihs-top*
306 si::*ihs-current*
307 si::*ihs-base*
308 si::*frs-base*
309 si::*frs-top*
310 si::*tpl-commands*
311 si::*tpl-level*
312 si::frs-top
313 si::ihs-top
314 si::ihs-fun
315 si::ihs-env
316 si::sch-frs-base
317 si::set-break-env
318 si::set-current-ihs
319 si::tpl-commands)))
f33058f1 »
2005-08-03 Initial port to ECL
320
6457beb9 »
2010-02-16 Pimp my swank.
321 (defun make-invoke-debugger-hook (hook)
322 (when hook
323 #'(lambda (condition old-hook)
324 ;; Regard *debugger-hook* if set by user.
325 (if *debugger-hook*
326 nil ; decline, *DEBUGGER-HOOK* will be tried next.
327 (funcall hook condition old-hook)))))
328
329 (defimplementation install-debugger-globally (function)
330 (setq *debugger-hook* function)
331 (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
332
333 (defimplementation call-with-debugger-hook (hook fun)
334 (let ((*debugger-hook* hook)
4d214b67 »
2010-02-20 More work on ECL's swank-backend.
335 (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
6457beb9 »
2010-02-16 Pimp my swank.
336 (funcall fun)))
337
a8e47da3 »
2008-04-30 Backtrace and frame/eval improvements
338 (defvar *backtrace* '())
339
4d214b67 »
2010-02-20 More work on ECL's swank-backend.
340 ;;; Commented out; it's not clear this is a good way of doing it. In
341 ;;; particular because it makes errors stemming from this file harder
342 ;;; to debug, and given the "young" age of ECL's swank backend, that's
343 ;;; a bad idea.
344
345 ;; (defun in-swank-package-p (x)
346 ;; (and
347 ;; (symbolp x)
348 ;; (member (symbol-package x)
349 ;; (list #.(find-package :swank)
350 ;; #.(find-package :swank-backend)
351 ;; #.(ignore-errors (find-package :swank-mop))
352 ;; #.(ignore-errors (find-package :swank-loader))))
353 ;; t))
354
355 ;; (defun is-swank-source-p (name)
356 ;; (setf name (pathname name))
357 ;; (pathname-match-p
358 ;; name
359 ;; (make-pathname :defaults swank-loader::*source-directory*
360 ;; :name (pathname-name name)
361 ;; :type (pathname-type name)
362 ;; :version (pathname-version name))))
363
364 ;; (defun is-ignorable-fun-p (x)
365 ;; (or
366 ;; (in-swank-package-p (frame-name x))
367 ;; (multiple-value-bind (file position)
368 ;; (ignore-errors (si::bc-file (car x)))
369 ;; (declare (ignore position))
370 ;; (if file (is-swank-source-p file)))))
36a60531 »
2008-05-01 Remove frames from the backtrace that are in a swank package as those…
371
f33058f1 »
2005-08-03 Initial port to ECL
372 (defimplementation call-with-debugging-environment (debugger-loop-fn)
373 (declare (type function debugger-loop-fn))
4e64b26a »
2010-02-23 * swank-backend.lisp (when-let): New macro. For backends and
374 (let* ((*ihs-top* (ihs-top))
6443eec2 »
2008-09-18 * swank-ecl.lisp: Forgot to update ECL's backend when introducing
375 (*ihs-current* *ihs-top*)
376 (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
377 (*frs-top* (frs-top))
378 (*tpl-level* (1+ *tpl-level*))
670648a5 »
2009-06-12 Support new environment changes in recent ECL/CVS
379 (*backtrace* (loop for ihs from 0 below *ihs-top*
36a60531 »
2008-05-01 Remove frames from the backtrace that are in a swank package as those…
380 collect (list (si::ihs-fun ihs)
a8e47da3 »
2008-04-30 Backtrace and frame/eval improvements
381 (si::ihs-env ihs)
382 nil))))
670648a5 »
2009-06-12 Support new environment changes in recent ECL/CVS
383 (declare (special *ihs-current*))
a8e47da3 »
2008-04-30 Backtrace and frame/eval improvements
384 (loop for f from *frs-base* until *frs-top*
385 do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
386 (when (plusp i)
387 (let* ((x (elt *backtrace* i))
388 (name (si::frs-tag f)))
ecef2536 »
2008-05-08 Bugfix: qualify fixnump
389 (unless (si::fixnump name)
a8e47da3 »
2008-04-30 Backtrace and frame/eval improvements
390 (push name (third x)))))))
4d214b67 »
2010-02-20 More work on ECL's swank-backend.
391 (setf *backtrace* (nreverse *backtrace*))
f33058f1 »
2005-08-03 Initial port to ECL
392 (set-break-env)
393 (set-current-ihs)
a8e47da3 »
2008-04-30 Backtrace and frame/eval improvements
394 (let ((*ihs-base* *ihs-top*))
395 (funcall debugger-loop-fn))))
f33058f1 »
2005-08-03 Initial port to ECL
396
397 (defimplementation compute-backtrace (start end)
a8e47da3 »
2008-04-30 Backtrace and frame/eval improvements
398 (when (numberp end)
399 (setf end (min end (length *backtrace*))))
6443eec2 »
2008-09-18 * swank-ecl.lisp: Forgot to update ECL's backend when introducing
400 (loop for f in (subseq *backtrace* start end)
954bd865 »
2008-10-17 * swank-backend.lisp (frame-restartable-p): New function.
401 collect f))
a8e47da3 »
2008-04-30 Backtrace and frame/eval improvements
402
403 (defun frame-name (frame)
404 (let ((x (first frame)))
405 (if (symbolp x)
406 x
407 (function-name x))))
408
409 (defun function-position (fun)
410 (multiple-value-bind (file position)
411 (si::bc-file fun)
4d214b67 »
2010-02-20 More work on ECL's swank-backend.
412 (when file
413 (make-file-location file position))))
a8e47da3 »
2008-04-30 Backtrace and frame/eval improvements
414
415 (defun frame-function (frame)
416 (let* ((x (first frame))
417 fun position)
418 (etypecase x
419 (symbol (and (fboundp x)
420 (setf fun (fdefinition x)
421 position (function-position fun))))
422 (function (setf fun x position (function-position x))))
423 (values fun position)))
424
425 (defun frame-decode-env (frame)
426 (let ((functions '())
427 (blocks '())
428 (variables '()))
6457beb9 »
2010-02-16 Pimp my swank.
429 (setf frame (si::decode-ihs-env (second frame)))
670648a5 »
2009-06-12 Support new environment changes in recent ECL/CVS
430 (dolist (record frame)
a8e47da3 »
2008-04-30 Backtrace and frame/eval improvements
431 (let* ((record0 (car record))
432 (record1 (cdr record)))
670648a5 »
2009-06-12 Support new environment changes in recent ECL/CVS
433 (cond ((or (symbolp record0) (stringp record0))
a8e47da3 »
2008-04-30 Backtrace and frame/eval improvements
434 (setq variables (acons record0 record1 variables)))
ecef2536 »
2008-05-08 Bugfix: qualify fixnump
435 ((not (si::fixnump record0))
a8e47da3 »
2008-04-30 Backtrace and frame/eval improvements
436 (push record1 functions))
437 ((symbolp record1)
438 (push record1 blocks))
439 (t
440 ))))
441 (values functions blocks variables)))
f33058f1 »
2005-08-03 Initial port to ECL
442
954bd865 »
2008-10-17 * swank-backend.lisp (frame-restartable-p): New function.
443 (defimplementation print-frame (frame stream)
444 (format stream "~A" (first frame)))
a8e47da3 »
2008-04-30 Backtrace and frame/eval improvements
445
e94c7410 »
2009-06-21 * swank-backend.lisp (frame-source-location): Renamed from
446 (defimplementation frame-source-location (frame-number)
a8e47da3 »
2008-04-30 Backtrace and frame/eval improvements
447 (nth-value 1 (frame-function (elt *backtrace* frame-number))))
448
449 (defimplementation frame-catch-tags (frame-number)
450 (third (elt *backtrace* frame-number)))
451
452 (defimplementation frame-locals (frame-number)
453 (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
454 with i = 0
455 collect (list :name name :id (prog1 i (incf i)) :value value)))
456
457 (defimplementation frame-var-value (frame-number var-id)
458 (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
459 var-id))
460
461 (defimplementation disassemble-frame (frame-number)
8e5db041 »
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
462 (let ((fun (frame-function (elt *backtrace* frame-number))))
a8e47da3 »
2008-04-30 Backtrace and frame/eval improvements
463 (disassemble fun)))
464
465 (defimplementation eval-in-frame (form frame-number)
466 (let ((env (second (elt *backtrace* frame-number))))
467 (si:eval-with-env form env)))
f33058f1 »
2005-08-03 Initial port to ECL
468
8e5db041 »
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
469
f33058f1 »
2005-08-03 Initial port to ECL
470 ;;;; Inspector
471
8e5db041 »
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
472 ;;; FIXME: Would be nice if it was possible to inspect objects
473 ;;; implemented in C.
6eb426db »
2008-01-19 Make ELC inspection better; should be able to handle all builtin type…
474
8e5db041 »
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
475
f33058f1 »
2005-08-03 Initial port to ECL
476 ;;;; Definitions
477
32ea92d7 »
2010-02-22 Make swank-ecl.lisp work with latest ECL Git HEAD.
478 ;;; FIXME: There ought to be a better way.
479 (eval-when (:compile-toplevel :load-toplevel :execute)
480 (defun c-function-p (object)
481 (and (functionp object)
482 (let ((fn-name (function-name object)))
483 (and fn-name (si:mangle-name fn-name t) t)))))
484
485 (deftype c-function ()
486 `(satisfies c-function-p))
487
488 (defvar +TAGS+ (namestring (translate-logical-pathname #P"SYS:TAGS")))
489
490 (defun assert-source-directory ()
491 (unless (probe-file #P"SRC:")
492 (error "ECL's source directory ~A does not exist. ~
493 You can specify a different location via the environment ~
494 variable `ECLSRCDIR'."
495 (namestring (translate-logical-pathname #P"SYS:")))))
496
497 (defun assert-TAGS-file ()
498 (unless (probe-file +TAGS+)
499 (error "No TAGS file ~A found. It should have been installed with ECL."
500 +TAGS+)))
3d76a5c0 »
2010-02-22 Make M-. be able to jump right into the C source for ECL.
501
502 (defun classify-definition-name (name)
503 (let ((types '()))
504 (when (fboundp name)
505 (cond ((special-operator-p name)
506 (push :special-operator types))
507 ((macro-function name)
508 (push :macro types))
509 ((typep (fdefinition name) 'generic-function)
510 (push :generic-function types))
511 ((si:mangle-name name t)
512 (push :c-function types))
513 (t
514 (push :lisp-function types))))
4e64b26a »
2010-02-23 * swank-backend.lisp (when-let): New macro. For backends and
515 (when (boundp name)
516 (cond ((constantp name)
517 (push :constant types))
518 (t
519 (push :global-variable types))))
3d76a5c0 »
2010-02-22 Make M-. be able to jump right into the C source for ECL.
520 types))
521
4e64b26a »
2010-02-23 * swank-backend.lisp (when-let): New macro. For backends and
522 (defun find-definitions-by-name (name)
523 (when-let (annotations (ext:get-annotation name 'si::location :all))
524 (loop for annotation in annotations
525 collect (destructuring-bind (op file . pos) annotation
526 `((,op ,name) ,(make-file-location file pos))))))
527
528 (defun find-definitions-by-type (name type)
3d76a5c0 »
2010-02-22 Make M-. be able to jump right into the C source for ECL.
529 (ecase type
530 (:lisp-function
4e64b26a »
2010-02-23 * swank-backend.lisp (when-let): New macro. For backends and
531 (when-let (loc (source-location (fdefinition name)))
532 (list `((defun ,name) ,loc))))
3d76a5c0 »
2010-02-22 Make M-. be able to jump right into the C source for ECL.
533 (:c-function
4e64b26a »
2010-02-23 * swank-backend.lisp (when-let): New macro. For backends and
534 (when-let (loc (source-location (fdefinition name)))
535 (list `((c-source ,name) ,loc))))
3d76a5c0 »
2010-02-22 Make M-. be able to jump right into the C source for ECL.
536 (:generic-function
537 (loop for method in (clos:generic-function-methods (fdefinition name))
538 for specs = (clos:method-specializers method)
539 for loc = (source-location method)
540 when loc
541 collect `((defmethod ,name ,specs) ,loc)))
542 (:macro
4e64b26a »
2010-02-23 * swank-backend.lisp (when-let): New macro. For backends and
543 (when-let (loc (source-location (macro-function name)))
544 (list `((defmacro ,name) ,loc))))
545 ((:special-operator :constant :global-variable))))
3d76a5c0 »
2010-02-22 Make M-. be able to jump right into the C source for ECL.
546
98a99bda »
2008-04-24 basic/simple implementation of find-definitions
547 (defimplementation find-definitions (name)
4e64b26a »
2010-02-23 * swank-backend.lisp (when-let): New macro. For backends and
548 (nconc (find-definitions-by-name name)
549 (mapcan #'(lambda (type) (find-definitions-by-type name type))
550 (classify-definition-name name))))
32ea92d7 »
2010-02-22 Make swank-ecl.lisp work with latest ECL Git HEAD.
551
3d76a5c0 »
2010-02-22 Make M-. be able to jump right into the C source for ECL.
552 (defun source-location (object)
32ea92d7 »
2010-02-22 Make swank-ecl.lisp work with latest ECL Git HEAD.
553 (converting-errors-to-error-location
554 (typecase object
555 (c-function
556 (assert-source-directory)
557 (assert-TAGS-file)
558 (let ((lisp-name (function-name object)))
559 (assert lisp-name)
560 (multiple-value-bind (flag c-name) (si:mangle-name lisp-name t)
561 (assert flag)
562 ;; In ECL's code base sometimes the mangled name is used
563 ;; directly, sometimes ECL's DPP magic of @LISP:SYMBOL is used.
564 ;; We cannot predict here, so we just provide two candidates.
565 (let* ((candidate1 c-name)
566 (candidate2 (format nil "~A::~A"
567 (package-name (symbol-package lisp-name))
568 (symbol-name lisp-name))))
569 (make-location `(:etags-file ,+TAGS+)
570 `(:tag ,candidate1 ,candidate2))))))
571 (function
572 ;; FIXME: EXT:C-F-FILE may return "/tmp/ECL_SWANK_KMOXtm" which
573 ;; are the temporary files stemming from C-c C-c.
574 (multiple-value-bind (file pos) (ext:compiled-function-file object)
575 (when file
576 (assert (probe-file file))
577 (assert (not (minusp pos)))
578 (make-file-location file pos))))
579 (method
580 ;; FIXME: This will always return NIL at the moment; ECL does not
581 ;; store debug information for methods yet.
582 (source-location (clos:method-function object))))))
3d76a5c0 »
2010-02-22 Make M-. be able to jump right into the C source for ECL.
583
584 (defimplementation find-source-location (object)
585 (or (source-location object)
586 (make-error-location "Source definition of ~S not found" object)))
2791323a »
2008-04-24 Initial support for find-source-location with functions
587
8e5db041 »
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
588
5c31ce66 »
2009-06-25 Profiling support by Marko Kocić
589 ;;;; Profiling
590
6457beb9 »
2010-02-16 Pimp my swank.
591 #+profile
592 (progn
593
5c31ce66 »
2009-06-25 Profiling support by Marko Kocić
594 (defimplementation profile (fname)
595 (when fname (eval `(profile:profile ,fname))))
596
597 (defimplementation unprofile (fname)
598 (when fname (eval `(profile:unprofile ,fname))))
599
600 (defimplementation unprofile-all ()
601 (profile:unprofile-all)
602 "All functions unprofiled.")
603
604 (defimplementation profile-report ()
605 (profile:report))
606
607 (defimplementation profile-reset ()
608 (profile:reset)
609 "Reset profiling counters.")
610
611 (defimplementation profiled-functions ()
612 (profile:profile))
613
07666629 »
2009-07-01 swank-ecl.lisp: Package profiling support
614 (defimplementation profile-package (package callers methods)
615 (declare (ignore callers methods))
616 (eval `(profile:profile ,(package-name (find-package package)))))
4d214b67 »
2010-02-20 More work on ECL's swank-backend.
617 ) ; #+profile (progn ...
07666629 »
2009-07-01 swank-ecl.lisp: Package profiling support
618
8e5db041 »
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
619
6457beb9 »
2010-02-16 Pimp my swank.
620 ;;;; Threads
5415cdcc »
2007-12-15 Add ECL threads implementation to swank
621
622 #+threads
623 (progn
624 (defvar *thread-id-counter* 0)
625
6457beb9 »
2010-02-16 Pimp my swank.
626 (defparameter *thread-id-map* (make-hash-table))
627
628 (defvar *thread-id-map-lock*
629 (mp:make-lock :name "thread id map lock"))
5415cdcc »
2007-12-15 Add ECL threads implementation to swank
630
631 (defimplementation spawn (fn &key name)
6457beb9 »
2010-02-16 Pimp my swank.
632 (mp:process-run-function name fn))
633
634 (defimplementation thread-id (target-thread)
635 (block thread-id
636 (mp:with-lock (*thread-id-map-lock*)
637 ;; Does TARGET-THREAD have an id already?
638 (maphash (lambda (id thread-pointer)
639 (let ((thread (si:weak-pointer-value thread-pointer)))
640 (cond ((not thread)
641 (remhash id *thread-id-map*))
642 ((eq thread target-thread)
643 (return-from thread-id id)))))
644 *thread-id-map*)
645 ;; TARGET-THREAD not found in *THREAD-ID-MAP*
646 (let ((id (incf *thread-id-counter*))
647 (thread-pointer (si:make-weak-pointer target-thread)))
648 (setf (gethash id *thread-id-map*) thread-pointer)
649 id))))
5415cdcc »
2007-12-15 Add ECL threads implementation to swank
650
651 (defimplementation find-thread (id)
6457beb9 »
2010-02-16 Pimp my swank.
652 (mp:with-lock (*thread-id-map-lock*)
4d214b67 »
2010-02-20 More work on ECL's swank-backend.
653 (let* ((thread-ptr (gethash id *thread-id-map*))
654 (thread (and thread-ptr (si:weak-pointer-value thread-ptr))))
6457beb9 »
2010-02-16 Pimp my swank.
655 (unless thread
656 (remhash id *thread-id-map*))
657 thread)))
5415cdcc »
2007-12-15 Add ECL threads implementation to swank
658
659 (defimplementation thread-name (thread)
660 (mp:process-name thread))
661
662 (defimplementation thread-status (thread)
6457beb9 »
2010-02-16 Pimp my swank.
663 (if (mp:process-active-p thread)
664 "RUNNING"
665 "STOPPED"))
5415cdcc »
2007-12-15 Add ECL threads implementation to swank
666
667 (defimplementation make-lock (&key name)
668 (mp:make-lock :name name))
669
670 (defimplementation call-with-lock-held (lock function)
671 (declare (type function function))
672 (mp:with-lock (lock) (funcall function)))
673
674 (defimplementation current-thread ()
675 mp:*current-process*)
676
677 (defimplementation all-threads ()
678 (mp:all-processes))
679
680 (defimplementation interrupt-thread (thread fn)
681 (mp:interrupt-process thread fn))
682
683 (defimplementation kill-thread (thread)
684 (mp:process-kill thread))
685
686 (defimplementation thread-alive-p (thread)
687 (mp:process-active-p thread))
688
6457beb9 »
2010-02-16 Pimp my swank.
689 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
690 (defvar *mailboxes* (list))
691 (declaim (type list *mailboxes*))
692
5415cdcc »
2007-12-15 Add ECL threads implementation to swank
693 (defstruct (mailbox (:conc-name mailbox.))
6457beb9 »
2010-02-16 Pimp my swank.
694 thread
695 (mutex (mp:make-lock))
696 (cvar (mp:make-condition-variable))
5415cdcc »
2007-12-15 Add ECL threads implementation to swank
697 (queue '() :type list))
698
699 (defun mailbox (thread)
700 "Return THREAD's mailbox."
6457beb9 »
2010-02-16 Pimp my swank.
701 (mp:with-lock (*mailbox-lock*)
702 (or (find thread *mailboxes* :key #'mailbox.thread)
703 (let ((mb (make-mailbox :thread thread)))
704 (push mb *mailboxes*)
705 mb))))
5415cdcc »
2007-12-15 Add ECL threads implementation to swank
706
707 (defimplementation send (thread message)
6457beb9 »
2010-02-16 Pimp my swank.
708 (let* ((mbox (mailbox thread))
709 (mutex (mailbox.mutex mbox)))
710 (mp:with-lock (mutex)
8fd36874 »
2010-02-07 * swank-ecl.lisp: Update threading code. ECL doesn't still work
711 (setf (mailbox.queue mbox)
712 (nconc (mailbox.queue mbox) (list message)))
713 (mp:condition-variable-broadcast (mailbox.cvar mbox)))))
714
715 (defimplementation receive-if (test &optional timeout)
6457beb9 »
2010-02-16 Pimp my swank.
716 (let* ((mbox (mailbox (current-thread)))
717 (mutex (mailbox.mutex mbox)))
8fd36874 »
2010-02-07 * swank-ecl.lisp: Update threading code. ECL doesn't still work
718 (assert (or (not timeout) (eq timeout t)))
719 (loop
6457beb9 »
2010-02-16 Pimp my swank.
720 (check-slime-interrupts)
721 (mp:with-lock (mutex)
722 (let* ((q (mailbox.queue mbox))
723 (tail (member-if test q)))
724 (when tail
725 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
726 (return (car tail))))
727 (when (eq timeout t) (return (values nil t)))
728 (mp:condition-variable-timedwait (mailbox.cvar mbox)
729 mutex
730 0.2)))))
731
732 ) ; #+threads (progn ...
Something went wrong with that request. Please try again.