Skip to content

HTTPS clone URL

Subversion checkout URL

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