Skip to content

HTTPS clone URL

Subversion checkout URL

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