Skip to content

HTTPS clone URL

Subversion checkout URL

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