Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 731 lines (606 sloc) 24.835 kb
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
1 ;;;; -*- indent-tabs-mode: nil -*-
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
2 ;;;
3 ;;; swank-ecl.lisp --- SLIME backend for ECL.
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
4 ;;;
5 ;;; This code has been placed in the Public Domain. All warranties
6 ;;; are disclaimed.
7 ;;;
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
8
9 ;;; Administrivia
10
11 (in-package :swank-backend)
12
6457beb @trittweiler Pimp my swank.
trittweiler authored
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
4d214b6 @trittweiler More work on ECL's swank-backend.
trittweiler authored
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
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
35 (declaim (optimize (debug 3)))
36
6457beb @trittweiler Pimp my swank.
trittweiler authored
37 ;;; Swank-mop
98a99bd basic/simple implementation of find-definitions
Geo Carncross authored
38
10425c0 * swank-ecl.lisp: Add :load-toplevel and :execute to EVAL-WHENs to
Helmut Eller authored
39 (eval-when (:compile-toplevel :load-toplevel :execute)
6457beb @trittweiler Pimp my swank.
trittweiler authored
40 (import-from :gray *gray-stream-symbols* :swank-backend)
fdfd77b @stassats * swank-ecl.lisp (swank-mop:compute-applicable-methods-using-classes):
stassats authored
41
6457beb @trittweiler Pimp my swank.
trittweiler authored
42 (import-swank-mop-symbols :clos
fdfd77b @stassats * swank-ecl.lisp (swank-mop:compute-applicable-methods-using-classes):
stassats authored
43 '(:eql-specializer
44 :eql-specializer-object
45 :generic-function-declarations
46 :specializer-direct-methods
47 :compute-applicable-methods-using-classes)))
48
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
49
50 ;;;; TCP Server
51
8e5db04 @trittweiler * swank-ecl.lisp (preferred-communication-style): Go back to
trittweiler authored
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
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
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
e51892e swank-backend.lisp (definterface): Drop that incredibly unportable
Helmut Eller authored
81 &key external-format
d4ac7e7 * Improve the robustness of connection establishment.
Douglas Crosher authored
82 buffering timeout)
4d214b6 @trittweiler More work on ECL's swank-backend.
trittweiler authored
83 (declare (ignore timeout))
6457beb @trittweiler Pimp my swank.
trittweiler authored
84 (sb-bsd-sockets:socket-make-stream (accept socket)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
85 :output t
86 :input t
4d214b6 @trittweiler More work on ECL's swank-backend.
trittweiler authored
87 :buffering buffering
88 :external-format external-format))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
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
8e5db04 @trittweiler * swank-ecl.lisp (preferred-communication-style): Go back to
trittweiler authored
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))))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
101
d253065 @trittweiler * swank-ecl.lisp (find-external-format): Copied from
trittweiler authored
102 (defvar *external-format-to-coding-system*
4d214b6 @trittweiler More work on ECL's swank-backend.
trittweiler authored
103 '((:latin-1
d253065 @trittweiler * swank-ecl.lisp (find-external-format): Copied from
trittweiler authored
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
4d214b6 @trittweiler More work on ECL's swank-backend.
trittweiler authored
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
d253065 @trittweiler * swank-ecl.lisp (find-external-format): Copied from
trittweiler authored
113 (defimplementation find-external-format (coding-system)
4d214b6 @trittweiler More work on ECL's swank-backend.
trittweiler authored
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)))
d253065 @trittweiler * swank-ecl.lisp (find-external-format): Copied from
trittweiler authored
123
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
124
4d214b6 @trittweiler More work on ECL's swank-backend.
trittweiler authored
125 ;;;; Unix Integration
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
126
6457beb @trittweiler Pimp my swank.
trittweiler authored
127 (defvar *original-sigint-handler* #'si:terminal-interrupt)
128
7be8fd7 Improve interrupt safety for single-threaded lisps.
Helmut Eller authored
129 (defimplementation install-sigint-handler (handler)
6457beb @trittweiler Pimp my swank.
trittweiler authored
130 (declare (function handler))
7be8fd7 Improve interrupt safety for single-threaded lisps.
Helmut Eller authored
131 (let ((old-handler (symbol-function 'si:terminal-interrupt)))
132 (setf (symbol-function 'si:terminal-interrupt)
6457beb @trittweiler Pimp my swank.
trittweiler authored
133 (if (eq handler *original-sigint-handler*)
134 handler
7be8fd7 Improve interrupt safety for single-threaded lisps.
Helmut Eller authored
135 (lambda (&rest args)
136 (declare (ignore args))
137 (funcall handler)
138 (continue))))
6457beb @trittweiler Pimp my swank.
trittweiler authored
139 old-handler))
7be8fd7 Improve interrupt safety for single-threaded lisps.
Helmut Eller authored
140
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
141 (defimplementation getpid ()
142 (si:getpid))
143
144 (defimplementation set-default-directory (directory)
6457beb @trittweiler Pimp my swank.
trittweiler authored
145 (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*.
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
146 (default-directory))
147
148 (defimplementation default-directory ()
149 (namestring (ext:getcwd)))
150
151 (defimplementation quit-lisp ()
152 (ext:quit))
153
154
6457beb @trittweiler Pimp my swank.
trittweiler authored
155
8e5db04 @trittweiler * swank-ecl.lisp (preferred-communication-style): Go back to
trittweiler authored
156 ;;; Instead of busy waiting with communication-style NIL, use select()
157 ;;; on the sockets' streams.
6457beb @trittweiler Pimp my swank.
trittweiler authored
158 #+serve-event
159 (progn
8e5db04 @trittweiler * swank-ecl.lisp (preferred-communication-style): Go back to
trittweiler authored
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
4e64b26 @trittweiler * swank-backend.lisp (when-let): New macro. For backends and
trittweiler authored
180 (when-let (ready (poll-streams streams 0.2))
181 (return ready))))))
6457beb @trittweiler Pimp my swank.
trittweiler authored
182
183 ) ; #+serve-event (progn ...
184
185
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
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
6457beb @trittweiler Pimp my swank.
trittweiler authored
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
4d214b6 @trittweiler More work on ECL's swank-backend.
trittweiler authored
200 :message (princ-to-string condition)
6457beb @trittweiler Pimp my swank.
trittweiler authored
201 :severity (etypecase condition
202 (c:compiler-fatal-error :error)
4d214b6 @trittweiler More work on ECL's swank-backend.
trittweiler authored
203 (c:compiler-error :error)
204 (error :error)
205 (style-warning :style-warning)
206 (warning :warning))
6457beb @trittweiler Pimp my swank.
trittweiler authored
207 :location (condition-location condition))))
208
4d214b6 @trittweiler More work on ECL's swank-backend.
trittweiler authored
209 (defun make-file-location (file file-position)
210 ;; File positions in CL start at 0, but Emacs' buffer positions
3d76a5c @trittweiler Make M-. be able to jump right into the C source for ECL.
trittweiler authored
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.
4d214b6 @trittweiler More work on ECL's swank-backend.
trittweiler authored
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
6457beb @trittweiler Pimp my swank.
trittweiler authored
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*
8e5db04 @trittweiler * swank-ecl.lisp (preferred-communication-style): Go back to
trittweiler authored
228 (make-buffer-location *buffer-name*
229 *buffer-start-position*
230 position)
4d214b6 @trittweiler More work on ECL's swank-backend.
trittweiler authored
231 (make-file-location file position))
6457beb @trittweiler Pimp my swank.
trittweiler authored
232 (make-error-location "No location found."))))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
233
234 (defimplementation call-with-compilation-hooks (function)
6457beb @trittweiler Pimp my swank.
trittweiler authored
235 (handler-bind ((c:compiler-message #'handle-compiler-message))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
236 (funcall function)))
237
f761f28 * swank-backend.lisp (swank-compile-file): Take output-file as
Helmut Eller authored
238 (defimplementation swank-compile-file (input-file output-file
239 load-p external-format)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
240 (with-compilation-hooks ()
4d214b6 @trittweiler More work on ECL's swank-backend.
trittweiler authored
241 (compile-file input-file :output-file output-file
242 :load load-p
243 :external-format external-format)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
244
4314d2e * swank-backend.lisp (swank-compile-string): Pass the
Helmut Eller authored
245 (defimplementation swank-compile-string (string &key buffer position filename
4d214b6 @trittweiler More work on ECL's swank-backend.
trittweiler authored
246 policy)
4314d2e * swank-backend.lisp (swank-compile-string): Pass the
Helmut Eller authored
247 (declare (ignore filename policy))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
248 (with-compilation-hooks ()
4d214b6 @trittweiler More work on ECL's swank-backend.
trittweiler authored
249 (let ((*buffer-name* buffer) ; for compilation hooks
6457beb @trittweiler Pimp my swank.
trittweiler authored
250 (*buffer-start-position* position))
3d76a5c @trittweiler Make M-. be able to jump right into the C source for ECL.
trittweiler authored
251 (let ((file (si:mkstemp "TMP:ECL-SWANK-"))
252 (fasl-file)
253 (warnings-p)
254 (failure-p))
4d214b6 @trittweiler More work on ECL's swank-backend.
trittweiler authored
255 (unwind-protect
256 (with-open-file (file-stream file :direction :output
257 :if-exists :supersede)
258 (write-string string file-stream)
259 (finish-output file-stream)
3d76a5c @trittweiler Make M-. be able to jump right into the C source for ECL.
trittweiler authored
260 (multiple-value-setq (fasl-file warnings-p failure-p)
261 (compile-file file :load t)))
262 (when (probe-file file)
263 (delete-file file))
264 (when fasl-file
265 (delete-file fasl-file)))
266 (not failure-p)))))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
267
268 ;;;; Documentation
269
270 (defimplementation arglist (name)
8e5db04 @trittweiler * swank-ecl.lisp (preferred-communication-style): Go back to
trittweiler authored
271 (multiple-value-bind (arglist foundp)
4e64b26 @trittweiler * swank-backend.lisp (when-let): New macro. For backends and
trittweiler authored
272 (ext:function-lambda-list name)
8e5db04 @trittweiler * swank-ecl.lisp (preferred-communication-style): Go back to
trittweiler authored
273 (if foundp arglist :not-available)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
274
e51892e swank-backend.lisp (definterface): Drop that incredibly unportable
Helmut Eller authored
275 (defimplementation function-name (f)
076253c @stassats * swank-ecl.lisp (function-name): Use clos:generic-function-name
stassats authored
276 (typecase f
277 (generic-function (clos:generic-function-name f))
278 (function (si:compiled-function-name f))))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
279
6457beb @trittweiler Pimp my swank.
trittweiler authored
280 ;; FIXME
281 ;; (defimplementation macroexpand-all (form))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
282
283 (defimplementation describe-symbol-for-emacs (symbol)
284 (let ((result '()))
285 (dolist (type '(:VARIABLE :FUNCTION :CLASS))
4e64b26 @trittweiler * swank-backend.lisp (when-let): New macro. For backends and
trittweiler authored
286 (when-let (doc (describe-definition symbol type))
287 (setf result (list* type doc result))))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
288 result))
289
290 (defimplementation describe-definition (name type)
291 (case type
292 (:variable (documentation name 'variable))
293 (:function (documentation name 'function))
294 (:class (documentation name 'class))
295 (t nil)))
296
8e5db04 @trittweiler * swank-ecl.lisp (preferred-communication-style): Go back to
trittweiler authored
297
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
298 ;;; Debugging
299
10425c0 * swank-ecl.lisp: Add :load-toplevel and :execute to EVAL-WHENs to
Helmut Eller authored
300 (eval-when (:compile-toplevel :load-toplevel :execute)
990fcea * contrib/swank-listener-hooks.lisp: Add missing IN-PACKAGE.
Helmut Eller authored
301 (import
302 '(si::*break-env*
303 si::*ihs-top*
304 si::*ihs-current*
305 si::*ihs-base*
306 si::*frs-base*
307 si::*frs-top*
308 si::*tpl-commands*
309 si::*tpl-level*
310 si::frs-top
311 si::ihs-top
312 si::ihs-fun
313 si::ihs-env
314 si::sch-frs-base
315 si::set-break-env
316 si::set-current-ihs
317 si::tpl-commands)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
318
6457beb @trittweiler Pimp my swank.
trittweiler authored
319 (defun make-invoke-debugger-hook (hook)
320 (when hook
321 #'(lambda (condition old-hook)
322 ;; Regard *debugger-hook* if set by user.
323 (if *debugger-hook*
324 nil ; decline, *DEBUGGER-HOOK* will be tried next.
325 (funcall hook condition old-hook)))))
326
327 (defimplementation install-debugger-globally (function)
328 (setq *debugger-hook* function)
329 (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
330
331 (defimplementation call-with-debugger-hook (hook fun)
332 (let ((*debugger-hook* hook)
4d214b6 @trittweiler More work on ECL's swank-backend.
trittweiler authored
333 (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
6457beb @trittweiler Pimp my swank.
trittweiler authored
334 (funcall fun)))
335
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
336 (defvar *backtrace* '())
337
4d214b6 @trittweiler More work on ECL's swank-backend.
trittweiler authored
338 ;;; Commented out; it's not clear this is a good way of doing it. In
339 ;;; particular because it makes errors stemming from this file harder
340 ;;; to debug, and given the "young" age of ECL's swank backend, that's
341 ;;; a bad idea.
342
343 ;; (defun in-swank-package-p (x)
344 ;; (and
345 ;; (symbolp x)
346 ;; (member (symbol-package x)
347 ;; (list #.(find-package :swank)
348 ;; #.(find-package :swank-backend)
349 ;; #.(ignore-errors (find-package :swank-mop))
350 ;; #.(ignore-errors (find-package :swank-loader))))
351 ;; t))
352
353 ;; (defun is-swank-source-p (name)
354 ;; (setf name (pathname name))
355 ;; (pathname-match-p
356 ;; name
357 ;; (make-pathname :defaults swank-loader::*source-directory*
358 ;; :name (pathname-name name)
359 ;; :type (pathname-type name)
360 ;; :version (pathname-version name))))
361
362 ;; (defun is-ignorable-fun-p (x)
363 ;; (or
364 ;; (in-swank-package-p (frame-name x))
365 ;; (multiple-value-bind (file position)
366 ;; (ignore-errors (si::bc-file (car x)))
367 ;; (declare (ignore position))
368 ;; (if file (is-swank-source-p file)))))
36a6053 Remove frames from the backtrace that are in a swank package as those…
Geo Carncross authored
369
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
370 (defimplementation call-with-debugging-environment (debugger-loop-fn)
371 (declare (type function debugger-loop-fn))
4e64b26 @trittweiler * swank-backend.lisp (when-let): New macro. For backends and
trittweiler authored
372 (let* ((*ihs-top* (ihs-top))
6443eec @trittweiler * swank-ecl.lisp: Forgot to update ECL's backend when introducing
trittweiler authored
373 (*ihs-current* *ihs-top*)
374 (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
375 (*frs-top* (frs-top))
376 (*tpl-level* (1+ *tpl-level*))
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
377 (*backtrace* (loop for ihs from 0 below *ihs-top*
36a6053 Remove frames from the backtrace that are in a swank package as those…
Geo Carncross authored
378 collect (list (si::ihs-fun ihs)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
379 (si::ihs-env ihs)
380 nil))))
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
381 (declare (special *ihs-current*))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
382 (loop for f from *frs-base* until *frs-top*
383 do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
384 (when (plusp i)
385 (let* ((x (elt *backtrace* i))
386 (name (si::frs-tag f)))
ecef253 Bugfix: qualify fixnump
Geo Carncross authored
387 (unless (si::fixnump name)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
388 (push name (third x)))))))
4d214b6 @trittweiler More work on ECL's swank-backend.
trittweiler authored
389 (setf *backtrace* (nreverse *backtrace*))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
390 (set-break-env)
391 (set-current-ihs)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
392 (let ((*ihs-base* *ihs-top*))
393 (funcall debugger-loop-fn))))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
394
395 (defimplementation compute-backtrace (start end)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
396 (when (numberp end)
397 (setf end (min end (length *backtrace*))))
6443eec @trittweiler * swank-ecl.lisp: Forgot to update ECL's backend when introducing
trittweiler authored
398 (loop for f in (subseq *backtrace* start end)
954bd86 * swank-backend.lisp (frame-restartable-p): New function.
Helmut Eller authored
399 collect f))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
400
401 (defun frame-name (frame)
402 (let ((x (first frame)))
403 (if (symbolp x)
404 x
405 (function-name x))))
406
407 (defun function-position (fun)
408 (multiple-value-bind (file position)
409 (si::bc-file fun)
4d214b6 @trittweiler More work on ECL's swank-backend.
trittweiler authored
410 (when file
411 (make-file-location file position))))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
412
413 (defun frame-function (frame)
414 (let* ((x (first frame))
415 fun position)
416 (etypecase x
417 (symbol (and (fboundp x)
418 (setf fun (fdefinition x)
419 position (function-position fun))))
420 (function (setf fun x position (function-position x))))
421 (values fun position)))
422
423 (defun frame-decode-env (frame)
424 (let ((functions '())
425 (blocks '())
426 (variables '()))
6457beb @trittweiler Pimp my swank.
trittweiler authored
427 (setf frame (si::decode-ihs-env (second frame)))
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
428 (dolist (record frame)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
429 (let* ((record0 (car record))
430 (record1 (cdr record)))
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
431 (cond ((or (symbolp record0) (stringp record0))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
432 (setq variables (acons record0 record1 variables)))
ecef253 Bugfix: qualify fixnump
Geo Carncross authored
433 ((not (si::fixnump record0))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
434 (push record1 functions))
435 ((symbolp record1)
436 (push record1 blocks))
437 (t
438 ))))
439 (values functions blocks variables)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
440
954bd86 * swank-backend.lisp (frame-restartable-p): New function.
Helmut Eller authored
441 (defimplementation print-frame (frame stream)
442 (format stream "~A" (first frame)))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
443
e94c741 * swank-backend.lisp (frame-source-location): Renamed from
Helmut Eller authored
444 (defimplementation frame-source-location (frame-number)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
445 (nth-value 1 (frame-function (elt *backtrace* frame-number))))
446
447 (defimplementation frame-catch-tags (frame-number)
448 (third (elt *backtrace* frame-number)))
449
450 (defimplementation frame-locals (frame-number)
451 (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
452 with i = 0
453 collect (list :name name :id (prog1 i (incf i)) :value value)))
454
455 (defimplementation frame-var-value (frame-number var-id)
456 (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
457 var-id))
458
459 (defimplementation disassemble-frame (frame-number)
8e5db04 @trittweiler * swank-ecl.lisp (preferred-communication-style): Go back to
trittweiler authored
460 (let ((fun (frame-function (elt *backtrace* frame-number))))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
461 (disassemble fun)))
462
463 (defimplementation eval-in-frame (form frame-number)
464 (let ((env (second (elt *backtrace* frame-number))))
465 (si:eval-with-env form env)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
466
8e5db04 @trittweiler * swank-ecl.lisp (preferred-communication-style): Go back to
trittweiler authored
467
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
468 ;;;; Inspector
469
8e5db04 @trittweiler * swank-ecl.lisp (preferred-communication-style): Go back to
trittweiler authored
470 ;;; FIXME: Would be nice if it was possible to inspect objects
471 ;;; implemented in C.
6eb426d Make ELC inspection better; should be able to handle all builtin type…
Geo Carncross authored
472
8e5db04 @trittweiler * swank-ecl.lisp (preferred-communication-style): Go back to
trittweiler authored
473
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
474 ;;;; Definitions
475
32ea92d @trittweiler Make swank-ecl.lisp work with latest ECL Git HEAD.
trittweiler authored
476 ;;; FIXME: There ought to be a better way.
477 (eval-when (:compile-toplevel :load-toplevel :execute)
478 (defun c-function-p (object)
479 (and (functionp object)
480 (let ((fn-name (function-name object)))
481 (and fn-name (si:mangle-name fn-name t) t)))))
482
483 (deftype c-function ()
484 `(satisfies c-function-p))
485
486 (defvar +TAGS+ (namestring (translate-logical-pathname #P"SYS:TAGS")))
487
488 (defun assert-source-directory ()
489 (unless (probe-file #P"SRC:")
490 (error "ECL's source directory ~A does not exist. ~
491 You can specify a different location via the environment ~
492 variable `ECLSRCDIR'."
493 (namestring (translate-logical-pathname #P"SYS:")))))
494
495 (defun assert-TAGS-file ()
496 (unless (probe-file +TAGS+)
497 (error "No TAGS file ~A found. It should have been installed with ECL."
498 +TAGS+)))
3d76a5c @trittweiler Make M-. be able to jump right into the C source for ECL.
trittweiler authored
499
500 (defun classify-definition-name (name)
501 (let ((types '()))
502 (when (fboundp name)
503 (cond ((special-operator-p name)
504 (push :special-operator types))
505 ((macro-function name)
506 (push :macro types))
507 ((typep (fdefinition name) 'generic-function)
508 (push :generic-function types))
509 ((si:mangle-name name t)
510 (push :c-function types))
511 (t
512 (push :lisp-function types))))
4e64b26 @trittweiler * swank-backend.lisp (when-let): New macro. For backends and
trittweiler authored
513 (when (boundp name)
514 (cond ((constantp name)
515 (push :constant types))
516 (t
517 (push :global-variable types))))
3d76a5c @trittweiler Make M-. be able to jump right into the C source for ECL.
trittweiler authored
518 types))
519
4e64b26 @trittweiler * swank-backend.lisp (when-let): New macro. For backends and
trittweiler authored
520 (defun find-definitions-by-name (name)
521 (when-let (annotations (ext:get-annotation name 'si::location :all))
522 (loop for annotation in annotations
523 collect (destructuring-bind (op file . pos) annotation
524 `((,op ,name) ,(make-file-location file pos))))))
525
526 (defun find-definitions-by-type (name type)
3d76a5c @trittweiler Make M-. be able to jump right into the C source for ECL.
trittweiler authored
527 (ecase type
528 (:lisp-function
4e64b26 @trittweiler * swank-backend.lisp (when-let): New macro. For backends and
trittweiler authored
529 (when-let (loc (source-location (fdefinition name)))
530 (list `((defun ,name) ,loc))))
3d76a5c @trittweiler Make M-. be able to jump right into the C source for ECL.
trittweiler authored
531 (:c-function
4e64b26 @trittweiler * swank-backend.lisp (when-let): New macro. For backends and
trittweiler authored
532 (when-let (loc (source-location (fdefinition name)))
533 (list `((c-source ,name) ,loc))))
3d76a5c @trittweiler Make M-. be able to jump right into the C source for ECL.
trittweiler authored
534 (:generic-function
535 (loop for method in (clos:generic-function-methods (fdefinition name))
536 for specs = (clos:method-specializers method)
537 for loc = (source-location method)
538 when loc
539 collect `((defmethod ,name ,specs) ,loc)))
540 (:macro
4e64b26 @trittweiler * swank-backend.lisp (when-let): New macro. For backends and
trittweiler authored
541 (when-let (loc (source-location (macro-function name)))
542 (list `((defmacro ,name) ,loc))))
543 ((:special-operator :constant :global-variable))))
3d76a5c @trittweiler Make M-. be able to jump right into the C source for ECL.
trittweiler authored
544
98a99bd basic/simple implementation of find-definitions
Geo Carncross authored
545 (defimplementation find-definitions (name)
4e64b26 @trittweiler * swank-backend.lisp (when-let): New macro. For backends and
trittweiler authored
546 (nconc (find-definitions-by-name name)
547 (mapcan #'(lambda (type) (find-definitions-by-type name type))
548 (classify-definition-name name))))
32ea92d @trittweiler Make swank-ecl.lisp work with latest ECL Git HEAD.
trittweiler authored
549
3d76a5c @trittweiler Make M-. be able to jump right into the C source for ECL.
trittweiler authored
550 (defun source-location (object)
32ea92d @trittweiler Make swank-ecl.lisp work with latest ECL Git HEAD.
trittweiler authored
551 (converting-errors-to-error-location
552 (typecase object
553 (c-function
554 (assert-source-directory)
555 (assert-TAGS-file)
556 (let ((lisp-name (function-name object)))
557 (assert lisp-name)
558 (multiple-value-bind (flag c-name) (si:mangle-name lisp-name t)
559 (assert flag)
560 ;; In ECL's code base sometimes the mangled name is used
561 ;; directly, sometimes ECL's DPP magic of @LISP:SYMBOL is used.
562 ;; We cannot predict here, so we just provide two candidates.
563 (let* ((candidate1 c-name)
564 (candidate2 (format nil "~A::~A"
565 (package-name (symbol-package lisp-name))
566 (symbol-name lisp-name))))
567 (make-location `(:etags-file ,+TAGS+)
568 `(:tag ,candidate1 ,candidate2))))))
569 (function
570 ;; FIXME: EXT:C-F-FILE may return "/tmp/ECL_SWANK_KMOXtm" which
571 ;; are the temporary files stemming from C-c C-c.
572 (multiple-value-bind (file pos) (ext:compiled-function-file object)
573 (when file
574 (assert (probe-file file))
575 (assert (not (minusp pos)))
576 (make-file-location file pos))))
577 (method
578 ;; FIXME: This will always return NIL at the moment; ECL does not
579 ;; store debug information for methods yet.
580 (source-location (clos:method-function object))))))
3d76a5c @trittweiler Make M-. be able to jump right into the C source for ECL.
trittweiler authored
581
582 (defimplementation find-source-location (object)
583 (or (source-location object)
584 (make-error-location "Source definition of ~S not found" object)))
2791323 Initial support for find-source-location with functions
Geo Carncross authored
585
8e5db04 @trittweiler * swank-ecl.lisp (preferred-communication-style): Go back to
trittweiler authored
586
5c31ce6 Profiling support by Marko Kocić
Geo Carncross authored
587 ;;;; Profiling
588
6457beb @trittweiler Pimp my swank.
trittweiler authored
589 #+profile
590 (progn
591
5c31ce6 Profiling support by Marko Kocić
Geo Carncross authored
592 (defimplementation profile (fname)
593 (when fname (eval `(profile:profile ,fname))))
594
595 (defimplementation unprofile (fname)
596 (when fname (eval `(profile:unprofile ,fname))))
597
598 (defimplementation unprofile-all ()
599 (profile:unprofile-all)
600 "All functions unprofiled.")
601
602 (defimplementation profile-report ()
603 (profile:report))
604
605 (defimplementation profile-reset ()
606 (profile:reset)
607 "Reset profiling counters.")
608
609 (defimplementation profiled-functions ()
610 (profile:profile))
611
0766662 swank-ecl.lisp: Package profiling support
Geo Carncross authored
612 (defimplementation profile-package (package callers methods)
613 (declare (ignore callers methods))
614 (eval `(profile:profile ,(package-name (find-package package)))))
4d214b6 @trittweiler More work on ECL's swank-backend.
trittweiler authored
615 ) ; #+profile (progn ...
0766662 swank-ecl.lisp: Package profiling support
Geo Carncross authored
616
8e5db04 @trittweiler * swank-ecl.lisp (preferred-communication-style): Go back to
trittweiler authored
617
6457beb @trittweiler Pimp my swank.
trittweiler authored
618 ;;;; Threads
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
619
620 #+threads
621 (progn
622 (defvar *thread-id-counter* 0)
623
6457beb @trittweiler Pimp my swank.
trittweiler authored
624 (defparameter *thread-id-map* (make-hash-table))
625
626 (defvar *thread-id-map-lock*
627 (mp:make-lock :name "thread id map lock"))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
628
629 (defimplementation spawn (fn &key name)
6457beb @trittweiler Pimp my swank.
trittweiler authored
630 (mp:process-run-function name fn))
631
632 (defimplementation thread-id (target-thread)
633 (block thread-id
634 (mp:with-lock (*thread-id-map-lock*)
635 ;; Does TARGET-THREAD have an id already?
636 (maphash (lambda (id thread-pointer)
637 (let ((thread (si:weak-pointer-value thread-pointer)))
638 (cond ((not thread)
639 (remhash id *thread-id-map*))
640 ((eq thread target-thread)
641 (return-from thread-id id)))))
642 *thread-id-map*)
643 ;; TARGET-THREAD not found in *THREAD-ID-MAP*
644 (let ((id (incf *thread-id-counter*))
645 (thread-pointer (si:make-weak-pointer target-thread)))
646 (setf (gethash id *thread-id-map*) thread-pointer)
647 id))))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
648
649 (defimplementation find-thread (id)
6457beb @trittweiler Pimp my swank.
trittweiler authored
650 (mp:with-lock (*thread-id-map-lock*)
4d214b6 @trittweiler More work on ECL's swank-backend.
trittweiler authored
651 (let* ((thread-ptr (gethash id *thread-id-map*))
652 (thread (and thread-ptr (si:weak-pointer-value thread-ptr))))
6457beb @trittweiler Pimp my swank.
trittweiler authored
653 (unless thread
654 (remhash id *thread-id-map*))
655 thread)))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
656
657 (defimplementation thread-name (thread)
658 (mp:process-name thread))
659
660 (defimplementation thread-status (thread)
6457beb @trittweiler Pimp my swank.
trittweiler authored
661 (if (mp:process-active-p thread)
662 "RUNNING"
663 "STOPPED"))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
664
665 (defimplementation make-lock (&key name)
666 (mp:make-lock :name name))
667
668 (defimplementation call-with-lock-held (lock function)
669 (declare (type function function))
670 (mp:with-lock (lock) (funcall function)))
671
672 (defimplementation current-thread ()
673 mp:*current-process*)
674
675 (defimplementation all-threads ()
676 (mp:all-processes))
677
678 (defimplementation interrupt-thread (thread fn)
679 (mp:interrupt-process thread fn))
680
681 (defimplementation kill-thread (thread)
682 (mp:process-kill thread))
683
684 (defimplementation thread-alive-p (thread)
685 (mp:process-active-p thread))
686
6457beb @trittweiler Pimp my swank.
trittweiler authored
687 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
688 (defvar *mailboxes* (list))
689 (declaim (type list *mailboxes*))
690
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
691 (defstruct (mailbox (:conc-name mailbox.))
6457beb @trittweiler Pimp my swank.
trittweiler authored
692 thread
693 (mutex (mp:make-lock))
694 (cvar (mp:make-condition-variable))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
695 (queue '() :type list))
696
697 (defun mailbox (thread)
698 "Return THREAD's mailbox."
6457beb @trittweiler Pimp my swank.
trittweiler authored
699 (mp:with-lock (*mailbox-lock*)
700 (or (find thread *mailboxes* :key #'mailbox.thread)
701 (let ((mb (make-mailbox :thread thread)))
702 (push mb *mailboxes*)
703 mb))))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
704
705 (defimplementation send (thread message)
6457beb @trittweiler Pimp my swank.
trittweiler authored
706 (let* ((mbox (mailbox thread))
707 (mutex (mailbox.mutex mbox)))
708 (mp:with-lock (mutex)
8fd3687 @trittweiler * swank-ecl.lisp: Update threading code. ECL doesn't still work
trittweiler authored
709 (setf (mailbox.queue mbox)
710 (nconc (mailbox.queue mbox) (list message)))
711 (mp:condition-variable-broadcast (mailbox.cvar mbox)))))
712
713 (defimplementation receive-if (test &optional timeout)
6457beb @trittweiler Pimp my swank.
trittweiler authored
714 (let* ((mbox (mailbox (current-thread)))
715 (mutex (mailbox.mutex mbox)))
8fd3687 @trittweiler * swank-ecl.lisp: Update threading code. ECL doesn't still work
trittweiler authored
716 (assert (or (not timeout) (eq timeout t)))
717 (loop
6457beb @trittweiler Pimp my swank.
trittweiler authored
718 (check-slime-interrupts)
719 (mp:with-lock (mutex)
720 (let* ((q (mailbox.queue mbox))
721 (tail (member-if test q)))
722 (when tail
723 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
724 (return (car tail))))
725 (when (eq timeout t) (return (values nil t)))
726 (mp:condition-variable-timedwait (mailbox.cvar mbox)
727 mutex
728 0.2)))))
729
730 ) ; #+threads (progn ...
Something went wrong with that request. Please try again.