Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

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