Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 633 lines (526 sloc) 20.497 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
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
13 (declaim (optimize (debug 3)))
14
98a99bd basic/simple implementation of find-definitions
Geo Carncross authored
15 (defvar *tmp*)
16
10425c0 * swank-ecl.lisp: Add :load-toplevel and :execute to EVAL-WHENs to
Helmut Eller authored
17 (eval-when (:compile-toplevel :load-toplevel :execute)
48bd841 ECL moved gray streams into GRAY package
Geo Carncross authored
18 (if (find-package :gray)
19 (import-from :gray *gray-stream-symbols* :swank-backend)
20 (import-from :ext *gray-stream-symbols* :swank-backend))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
21
22 (swank-backend::import-swank-mop-symbols :clos
23 '(:eql-specializer
24 :eql-specializer-object
25 :generic-function-declarations
26 :specializer-direct-methods
990fcea * contrib/swank-listener-hooks.lisp: Add missing IN-PACKAGE.
Helmut Eller authored
27 :compute-applicable-methods-using-classes)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
28
29
30 ;;;; TCP Server
31
990fcea * contrib/swank-listener-hooks.lisp: Add missing IN-PACKAGE.
Helmut Eller authored
32 (eval-when (:compile-toplevel :load-toplevel :execute)
33 (require 'sockets))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
34
35 (defun resolve-hostname (name)
36 (car (sb-bsd-sockets:host-ent-addresses
37 (sb-bsd-sockets:get-host-by-name name))))
38
39 (defimplementation create-socket (host port)
40 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
41 :type :stream
42 :protocol :tcp)))
43 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
44 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
45 (sb-bsd-sockets:socket-listen socket 5)
46 socket))
47
48 (defimplementation local-port (socket)
49 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
50
51 (defimplementation close-socket (socket)
52 (sb-bsd-sockets:socket-close socket))
53
54 (defimplementation accept-connection (socket
e51892e swank-backend.lisp (definterface): Drop that incredibly unportable
Helmut Eller authored
55 &key external-format
d4ac7e7 * Improve the robustness of connection establishment.
Douglas Crosher authored
56 buffering timeout)
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
57 (declare (ignore buffering timeout external-format))
58 (make-socket-io-stream (accept socket)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
59
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
60 (defun make-socket-io-stream (socket)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
61 (sb-bsd-sockets:socket-make-stream socket
62 :output t
63 :input t
64 :element-type 'base-char))
65
66 (defun accept (socket)
67 "Like socket-accept, but retry on EAGAIN."
68 (loop (handler-case
69 (return (sb-bsd-sockets:socket-accept socket))
70 (sb-bsd-sockets:interrupted-error ()))))
71
72 (defimplementation preferred-communication-style ()
73 (values nil))
74
d253065 @trittweiler * swank-ecl.lisp (find-external-format): Copied from
trittweiler authored
75 (defvar *external-format-to-coding-system*
76 '((:iso-8859-1
77 "latin-1" "latin-1-unix" "iso-latin-1-unix"
78 "iso-8859-1" "iso-8859-1-unix")
79 (:utf-8 "utf-8" "utf-8-unix")))
80
81 (defimplementation find-external-format (coding-system)
82 (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
83 *external-format-to-coding-system*)))
84
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
85
86 ;;;; Unix signals
87
7be8fd7 Improve interrupt safety for single-threaded lisps.
Helmut Eller authored
88 (defimplementation install-sigint-handler (handler)
89 (let ((old-handler (symbol-function 'si:terminal-interrupt)))
90 (setf (symbol-function 'si:terminal-interrupt)
91 (if (consp handler)
92 (car handler)
93 (lambda (&rest args)
94 (declare (ignore args))
95 (funcall handler)
96 (continue))))
97 (list old-handler)))
98
99
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
100 (defimplementation getpid ()
101 (si:getpid))
102
103 #+nil
104 (defimplementation set-default-directory (directory)
105 (ext::chdir (namestring directory))
106 ;; Setting *default-pathname-defaults* to an absolute directory
107 ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
108 (setf *default-pathname-defaults* (ext::getcwd))
109 (default-directory))
110
111 #+nil
112 (defimplementation default-directory ()
113 (namestring (ext:getcwd)))
114
115 (defimplementation quit-lisp ()
116 (ext:quit))
117
118
119 ;;;; Compilation
120
121 (defvar *buffer-name* nil)
122 (defvar *buffer-start-position*)
123 (defvar *buffer-string*)
124 (defvar *compile-filename*)
125
126 (defun signal-compiler-condition (&rest args)
127 (signal (apply #'make-condition 'compiler-condition args)))
128
129 (defun handle-compiler-warning (condition)
130 (signal-compiler-condition
131 :original-condition condition
132 :message (format nil "~A" condition)
133 :severity :warning
134 :location
135 (if *buffer-name*
136 (make-location (list :buffer *buffer-name*)
b88eba2 Adjust positions in files with CRLF-style end-on-line markers.
Helmut Eller authored
137 (list :offset *buffer-start-position* 0))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
138 ;; ;; compiler::*current-form*
139 ;; (if compiler::*current-function*
140 ;; (make-location (list :file *compile-filename*)
141 ;; (list :function-name
142 ;; (symbol-name
143 ;; (slot-value compiler::*current-function*
144 ;; 'compiler::name))))
145 (list :error "No location found.")
146 ;; )
147 )))
148
149 (defimplementation call-with-compilation-hooks (function)
150 (handler-bind ((warning #'handle-compiler-warning))
151 (funcall function)))
152
f761f28 * swank-backend.lisp (swank-compile-file): Take output-file as
Helmut Eller authored
153 (defimplementation swank-compile-file (input-file output-file
154 load-p external-format)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
155 (declare (ignore external-format))
156 (with-compilation-hooks ()
f761f28 * swank-backend.lisp (swank-compile-file): Take output-file as
Helmut Eller authored
157 (let ((*buffer-name* nil)
158 (*compile-filename* input-file))
159 (compile-file input-file :output-file output-file :load t))))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
160
4314d2e * swank-backend.lisp (swank-compile-string): Pass the
Helmut Eller authored
161 (defimplementation swank-compile-string (string &key buffer position filename
162 policy)
163 (declare (ignore filename policy))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
164 (with-compilation-hooks ()
165 (let ((*buffer-name* buffer)
166 (*buffer-start-position* position)
167 (*buffer-string* string))
168 (with-input-from-string (s string)
601b824 * swank-lispworks.lisp (with-swank-compilation-unit): Return the
Helmut Eller authored
169 (not (nth-value 2 (compile-from-stream s :load t)))))))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
170
171 (defun compile-from-stream (stream &rest args)
172 (let ((file (si::mkstemp "TMP:ECLXXXXXX")))
173 (with-open-file (s file :direction :output :if-exists :overwrite)
174 (do ((line (read-line stream nil) (read-line stream nil)))
d2ab4d0 @trittweiler * swank-ecl.lisp (compile-from-stream): Fixed typo that prevented
trittweiler authored
175 ((not line))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
176 (write-line line s)))
177 (unwind-protect
178 (apply #'compile-file file args)
179 (delete-file file))))
180
181
182 ;;;; Documentation
183
5e3751b @trittweiler Improve ECL's arglist support somewhat.
trittweiler authored
184 (defun grovel-docstring-for-arglist (name type)
185 (flet ((compute-arglist-offset (docstring)
186 (when docstring
187 (let ((pos1 (search "Args: " docstring)))
188 (if pos1
189 (+ pos1 6)
190 (let ((pos2 (search "Syntax: " docstring)))
191 (when pos2
192 (+ pos2 8))))))))
193 (let* ((docstring (si::get-documentation name type))
194 (pos (compute-arglist-offset docstring)))
195 (if pos
196 (multiple-value-bind (arglist errorp)
197 (ignore-errors
198 (values (read-from-string docstring t nil :start pos)))
329a5f5 2009-01-30 Geo Carncross <geocar@gmail.com>
Geo Carncross authored
199 (if (or errorp (not (listp arglist)))
200 :not-available
201 (cdr arglist)))
5e3751b @trittweiler Improve ECL's arglist support somewhat.
trittweiler authored
202 :not-available ))))
203
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
204 (defimplementation arglist (name)
5e3751b @trittweiler Improve ECL's arglist support somewhat.
trittweiler authored
205 (cond ((special-operator-p name)
206 (grovel-docstring-for-arglist name 'function))
207 ((macro-function name)
208 (grovel-docstring-for-arglist name 'function))
209 ((or (functionp name) (fboundp name))
210 (multiple-value-bind (name fndef)
211 (if (functionp name)
212 (values (function-name name) name)
213 (values name (fdefinition name)))
214 (typecase fndef
215 (generic-function
216 (clos::generic-function-lambda-list fndef))
217 (compiled-function
218 (grovel-docstring-for-arglist name 'function))
219 (function
220 (let ((fle (function-lambda-expression fndef)))
221 (case (car fle)
222 (si:lambda-block (caddr fle))
223 (t :not-available)))))))
224 (t :not-available)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
225
e51892e swank-backend.lisp (definterface): Drop that incredibly unportable
Helmut Eller authored
226 (defimplementation function-name (f)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
227 (si:compiled-function-name f))
228
229 (defimplementation macroexpand-all (form)
230 ;;; FIXME! This is not the same as a recursive macroexpansion!
231 (macroexpand form))
232
233 (defimplementation describe-symbol-for-emacs (symbol)
234 (let ((result '()))
235 (dolist (type '(:VARIABLE :FUNCTION :CLASS))
236 (let ((doc (describe-definition symbol type)))
237 (when doc
238 (setf result (list* type doc result)))))
239 result))
240
241 (defimplementation describe-definition (name type)
242 (case type
243 (:variable (documentation name 'variable))
244 (:function (documentation name 'function))
245 (:class (documentation name 'class))
246 (t nil)))
247
248 ;;; Debugging
249
10425c0 * swank-ecl.lisp: Add :load-toplevel and :execute to EVAL-WHENs to
Helmut Eller authored
250 (eval-when (:compile-toplevel :load-toplevel :execute)
990fcea * contrib/swank-listener-hooks.lisp: Add missing IN-PACKAGE.
Helmut Eller authored
251 (import
252 '(si::*break-env*
253 si::*ihs-top*
254 si::*ihs-current*
255 si::*ihs-base*
256 si::*frs-base*
257 si::*frs-top*
258 si::*tpl-commands*
259 si::*tpl-level*
260 si::frs-top
261 si::ihs-top
262 si::ihs-fun
263 si::ihs-env
264 si::sch-frs-base
265 si::set-break-env
266 si::set-current-ihs
267 si::tpl-commands)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
268
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
269 (defvar *backtrace* '())
270
36a6053 Remove frames from the backtrace that are in a swank package as those…
Geo Carncross authored
271 (defun in-swank-package-p (x)
df8f365 Trim swank sources from the ECL backtrace.
Geo Carncross authored
272 (and
273 (symbolp x)
274 (member (symbol-package x)
275 (list #.(find-package :swank)
276 #.(find-package :swank-backend)
277 #.(ignore-errors (find-package :swank-mop))
278 #.(ignore-errors (find-package :swank-loader))))
279 t))
280
281 (defun is-swank-source-p (name)
282 (setf name (pathname name))
283 (pathname-match-p
284 name
285 (make-pathname :defaults swank-loader::*source-directory*
286 :name (pathname-name name)
287 :type (pathname-type name)
288 :version (pathname-version name))))
289
290 (defun is-ignorable-fun-p (x)
291 (or
292 (in-swank-package-p (frame-name x))
293 (multiple-value-bind (file position)
294 (ignore-errors (si::bc-file (car x)))
295 (declare (ignore position))
296 (if file (is-swank-source-p file)))))
36a6053 Remove frames from the backtrace that are in a swank package as those…
Geo Carncross authored
297
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
298 (defmacro find-ihs-top (x)
299 (if (< ext:+ecl-version-number+ 90601)
300 `(si::ihs-top ,x)
301 '(si::ihs-top)))
302
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
303 (defimplementation call-with-debugging-environment (debugger-loop-fn)
304 (declare (type function debugger-loop-fn))
305 (let* ((*tpl-commands* si::tpl-commands)
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
306 (*ihs-top* (find-ihs-top 'call-with-debugging-environment))
6443eec @trittweiler * swank-ecl.lisp: Forgot to update ECL's backend when introducing
trittweiler authored
307 (*ihs-current* *ihs-top*)
308 (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
309 (*frs-top* (frs-top))
310 (*read-suppress* nil)
311 (*tpl-level* (1+ *tpl-level*))
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
312 (*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
313 collect (list (si::ihs-fun ihs)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
314 (si::ihs-env ihs)
315 nil))))
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
316 (declare (special *ihs-current*))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
317 (loop for f from *frs-base* until *frs-top*
318 do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
319 (when (plusp i)
320 (let* ((x (elt *backtrace* i))
321 (name (si::frs-tag f)))
ecef253 Bugfix: qualify fixnump
Geo Carncross authored
322 (unless (si::fixnump name)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
323 (push name (third x)))))))
df8f365 Trim swank sources from the ECL backtrace.
Geo Carncross authored
324 (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))
6443eec @trittweiler * swank-ecl.lisp: Forgot to update ECL's backend when introducing
trittweiler authored
325 (setf *tmp* *backtrace*)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
326 (set-break-env)
327 (set-current-ihs)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
328 (let ((*ihs-base* *ihs-top*))
329 (funcall debugger-loop-fn))))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
330
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
331 (defimplementation call-with-debugger-hook (hook fun)
332 (let ((*debugger-hook* hook)
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
333 (*ihs-base* (find-ihs-top 'call-with-debugger-hook)))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
334 (funcall fun)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
335
336 (defimplementation compute-backtrace (start end)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
337 (when (numberp end)
338 (setf end (min end (length *backtrace*))))
6443eec @trittweiler * swank-ecl.lisp: Forgot to update ECL's backend when introducing
trittweiler authored
339 (loop for f in (subseq *backtrace* start end)
954bd86 * swank-backend.lisp (frame-restartable-p): New function.
Helmut Eller authored
340 collect f))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
341
342 (defun frame-name (frame)
343 (let ((x (first frame)))
344 (if (symbolp x)
345 x
346 (function-name x))))
347
348 (defun function-position (fun)
349 (multiple-value-bind (file position)
350 (si::bc-file fun)
351 (and file (make-location `(:file ,file) `(:position ,position)))))
352
353 (defun frame-function (frame)
354 (let* ((x (first frame))
355 fun position)
356 (etypecase x
357 (symbol (and (fboundp x)
358 (setf fun (fdefinition x)
359 position (function-position fun))))
360 (function (setf fun x position (function-position x))))
361 (values fun position)))
362
363 (defun frame-decode-env (frame)
364 (let ((functions '())
365 (blocks '())
366 (variables '()))
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
367 #.(if (< ext:+ecl-version-number+ 90601)
368 '(setf frame (second frame))
369 '(setf frame (si::decode-ihs-env (second frame))))
370 (dolist (record frame)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
371 (let* ((record0 (car record))
372 (record1 (cdr record)))
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
373 (cond ((or (symbolp record0) (stringp record0))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
374 (setq variables (acons record0 record1 variables)))
ecef253 Bugfix: qualify fixnump
Geo Carncross authored
375 ((not (si::fixnump record0))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
376 (push record1 functions))
377 ((symbolp record1)
378 (push record1 blocks))
379 (t
380 ))))
381 (values functions blocks variables)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
382
954bd86 * swank-backend.lisp (frame-restartable-p): New function.
Helmut Eller authored
383 (defimplementation print-frame (frame stream)
384 (format stream "~A" (first frame)))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
385
e94c741 * swank-backend.lisp (frame-source-location): Renamed from
Helmut Eller authored
386 (defimplementation frame-source-location (frame-number)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
387 (nth-value 1 (frame-function (elt *backtrace* frame-number))))
388
389 (defimplementation frame-catch-tags (frame-number)
390 (third (elt *backtrace* frame-number)))
391
392 (defimplementation frame-locals (frame-number)
393 (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
394 with i = 0
395 collect (list :name name :id (prog1 i (incf i)) :value value)))
396
397 (defimplementation frame-var-value (frame-number var-id)
398 (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
399 var-id))
400
401 (defimplementation disassemble-frame (frame-number)
402 (let ((fun (frame-fun (elt *backtrace* frame-number))))
403 (disassemble fun)))
404
405 (defimplementation eval-in-frame (form frame-number)
406 (let ((env (second (elt *backtrace* frame-number))))
407 (si:eval-with-env form env)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
408
409 ;;;; Inspector
410
0c75cea Inspector cleanups.
Helmut Eller authored
411 (defmethod emacs-inspect ((o t))
6eb426d Make ELC inspection better; should be able to handle all builtin type…
Geo Carncross authored
412 ; ecl clos support leaves some to be desired
413 (cond
414 ((streamp o)
6a300a7 Drop the first return value of emacs-inspect.
Helmut Eller authored
415 (list*
416 (format nil "~S is an ordinary stream~%" o)
6eb426d Make ELC inspection better; should be able to handle all builtin type…
Geo Carncross authored
417 (append
418 (list
419 "Open for "
420 (cond
421 ((ignore-errors (interactive-stream-p o)) "Interactive")
422 ((and (input-stream-p o) (output-stream-p o)) "Input and output")
423 ((input-stream-p o) "Input")
424 ((output-stream-p o) "Output"))
425 `(:newline) `(:newline))
426 (label-value-line*
427 ("Element type" (stream-element-type o))
428 ("External format" (stream-external-format o)))
429 (ignore-errors (label-value-line*
430 ("Broadcast streams" (broadcast-stream-streams o))))
431 (ignore-errors (label-value-line*
432 ("Concatenated streams" (concatenated-stream-streams o))))
433 (ignore-errors (label-value-line*
434 ("Echo input stream" (echo-stream-input-stream o))))
435 (ignore-errors (label-value-line*
436 ("Echo output stream" (echo-stream-output-stream o))))
437 (ignore-errors (label-value-line*
438 ("Output String" (get-output-stream-string o))))
439 (ignore-errors (label-value-line*
440 ("Synonym symbol" (synonym-stream-symbol o))))
441 (ignore-errors (label-value-line*
442 ("Input stream" (two-way-stream-input-stream o))))
443 (ignore-errors (label-value-line*
444 ("Output stream" (two-way-stream-output-stream o)))))))
445 (t
446 (let* ((cl (si:instance-class o))
447 (slots (clos:class-slots cl)))
6a300a7 Drop the first return value of emacs-inspect.
Helmut Eller authored
448 (list* (format nil "~S is an instance of class ~A~%"
6eb426d Make ELC inspection better; should be able to handle all builtin type…
Geo Carncross authored
449 o (clos::class-name cl))
450 (loop for x in slots append
451 (let* ((name (clos:slot-definition-name x))
452 (value (clos::slot-value o name)))
453 (list
454 (format nil "~S: " name)
455 `(:value ,value)
456 `(:newline)))))))))
457
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
458 ;;;; Definitions
459
98a99bd basic/simple implementation of find-definitions
Geo Carncross authored
460 (defimplementation find-definitions (name)
461 (if (fboundp name)
462 (let ((tmp (find-source-location (symbol-function name))))
463 `(((defun ,name) ,tmp)))))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
464
2791323 Initial support for find-source-location with functions
Geo Carncross authored
465 (defimplementation find-source-location (obj)
98a99bd basic/simple implementation of find-definitions
Geo Carncross authored
466 (setf *tmp* obj)
2791323 Initial support for find-source-location with functions
Geo Carncross authored
467 (or
468 (typecase obj
469 (function
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
470 (multiple-value-bind (file pos) (ignore-errors (si::bc-file obj))
2791323 Initial support for find-source-location with functions
Geo Carncross authored
471 (if (and file pos)
e8c6143 fixup flushing and location create
Geo Carncross authored
472 (make-location
98a99bd basic/simple implementation of find-definitions
Geo Carncross authored
473 `(:file ,(namestring file))
e8c6143 fixup flushing and location create
Geo Carncross authored
474 `(:position ,pos)
475 `(:snippet
476 ,(with-open-file (s file)
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
477 (if (< ext:+ecl-version-number+ 90601)
478 (skip-toplevel-forms pos s)
479 (file-position s pos))
e8c6143 fixup flushing and location create
Geo Carncross authored
480 (skip-comments-and-whitespace s)
481 (read-snippet s))))))))
2791323 Initial support for find-source-location with functions
Geo Carncross authored
482 `(:error (format nil "Source definition of ~S not found" obj))))
483
5c31ce6 Profiling support by Marko Kocić
Geo Carncross authored
484 ;;;; Profiling
485
486 (eval-when (:compile-toplevel :load-toplevel :execute)
487 (require 'profile))
488
489 (defimplementation profile (fname)
490 (when fname (eval `(profile:profile ,fname))))
491
492 (defimplementation unprofile (fname)
493 (when fname (eval `(profile:unprofile ,fname))))
494
495 (defimplementation unprofile-all ()
496 (profile:unprofile-all)
497 "All functions unprofiled.")
498
499 (defimplementation profile-report ()
500 (profile:report))
501
502 (defimplementation profile-reset ()
503 (profile:reset)
504 "Reset profiling counters.")
505
506 (defimplementation profiled-functions ()
507 (profile:profile))
508
0766662 swank-ecl.lisp: Package profiling support
Geo Carncross authored
509 (defimplementation profile-package (package callers methods)
510 (declare (ignore callers methods))
511 (eval `(profile:profile ,(package-name (find-package package)))))
512
513
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
514 ;;;; Threads
515
516 #+threads
517 (progn
518 (defvar *thread-id-counter* 0)
519
520 (defvar *thread-id-counter-lock*
521 (mp:make-lock :name "thread id counter lock"))
522
523 (defun next-thread-id ()
524 (mp:with-lock (*thread-id-counter-lock*)
525 (incf *thread-id-counter*)))
526
527 (defparameter *thread-id-map* (make-hash-table))
3dfff7b * swank-ecl.lisp (thread-id): Assign an non-nil id to unknown
Helmut Eller authored
528 (defparameter *id-thread-map* (make-hash-table))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
529
530 (defvar *thread-id-map-lock*
531 (mp:make-lock :name "thread id map lock"))
532
533 ; ecl doesn't have weak pointers
534 (defimplementation spawn (fn &key name)
535 (let ((thread (mp:make-process :name name))
536 (id (next-thread-id)))
537 (mp:process-preset
538 thread
539 #'(lambda ()
540 (unwind-protect
541 (mp:with-lock (*thread-id-map-lock*)
3dfff7b * swank-ecl.lisp (thread-id): Assign an non-nil id to unknown
Helmut Eller authored
542 (setf (gethash id *thread-id-map*) thread)
543 (setf (gethash thread *id-thread-map*) id))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
544 (funcall fn)
545 (mp:with-lock (*thread-id-map-lock*)
3dfff7b * swank-ecl.lisp (thread-id): Assign an non-nil id to unknown
Helmut Eller authored
546 (remhash thread *id-thread-map*)
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
547 (remhash id *thread-id-map*)))))
548 (mp:process-enable thread)))
549
550 (defimplementation thread-id (thread)
551 (block thread-id
552 (mp:with-lock (*thread-id-map-lock*)
3dfff7b * swank-ecl.lisp (thread-id): Assign an non-nil id to unknown
Helmut Eller authored
553 (or (gethash thread *id-thread-map*)
554 (let ((id (next-thread-id)))
555 (setf (gethash id *thread-id-map*) thread)
556 (setf (gethash thread *id-thread-map*) id)
557 id)))))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
558
559 (defimplementation find-thread (id)
560 (mp:with-lock (*thread-id-map-lock*)
561 (gethash id *thread-id-map*)))
562
563 (defimplementation thread-name (thread)
564 (mp:process-name thread))
565
566 (defimplementation thread-status (thread)
567 (if (mp:process-active-p thread)
568 "RUNNING"
569 "STOPPED"))
570
571 (defimplementation make-lock (&key name)
572 (mp:make-lock :name name))
573
574 (defimplementation call-with-lock-held (lock function)
575 (declare (type function function))
576 (mp:with-lock (lock) (funcall function)))
577
578 (defimplementation current-thread ()
579 mp:*current-process*)
580
581 (defimplementation all-threads ()
582 (mp:all-processes))
583
584 (defimplementation interrupt-thread (thread fn)
585 (mp:interrupt-process thread fn))
586
587 (defimplementation kill-thread (thread)
588 (mp:process-kill thread))
589
590 (defimplementation thread-alive-p (thread)
591 (mp:process-active-p thread))
592
593 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
594
595 (defstruct (mailbox (:conc-name mailbox.))
596 (mutex (mp:make-lock :name "process mailbox"))
597 (queue '() :type list))
598
599 (defun mailbox (thread)
600 "Return THREAD's mailbox."
601 (mp:with-lock (*mailbox-lock*)
602 (or (find thread *mailboxes* :key #'mailbox.thread)
603 (let ((mb (make-mailbox :thread thread)))
604 (push mb *mailboxes*)
605 mb))))
606
607 (defimplementation send (thread message)
608 (let* ((mbox (mailbox thread))
609 (mutex (mailbox.mutex mbox)))
610 (mp:interrupt-process
611 thread
612 (lambda ()
613 (mp:with-lock (mutex)
614 (setf (mailbox.queue mbox)
615 (nconc (mailbox.queue mbox) (list message))))))))
616
617 (defimplementation receive ()
618 (block got-mail
619 (let* ((mbox (mailbox mp:*current-process*))
620 (mutex (mailbox.mutex mbox)))
621 (loop
622 (mp:with-lock (mutex)
623 (if (mailbox.queue mbox)
624 (return-from got-mail (pop (mailbox.queue mbox)))))
625 ;interrupt-process will halt this if it takes longer than 1sec
626 (sleep 1)))))
627
628 (defmethod stream-finish-output ((stream stream))
629 (finish-output stream))
630
631 )
632
Something went wrong with that request. Please try again.