/[slime]/slime/swank-ecl.lisp
ViewVC logotype

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.77 - (hide annotations)
Sat Aug 4 23:48:19 2012 UTC (20 months, 1 week ago) by sboukarev
Branch: MAIN
Changes since 1.76: +1 -1 lines
* clean up: (signal (make-condition ...)) => (signal ...)
1 heller 1.7 ;;;; -*- indent-tabs-mode: nil -*-
2 jgarcia 1.1 ;;;
3     ;;; swank-ecl.lisp --- SLIME backend for ECL.
4 heller 1.7 ;;;
5     ;;; This code has been placed in the Public Domain. All warranties
6     ;;; are disclaimed.
7     ;;;
8 jgarcia 1.1
9     ;;; Administrivia
10    
11     (in-package :swank-backend)
12    
13 trittweiler 1.52 (eval-when (:compile-toplevel :load-toplevel :execute)
14     (let ((version (find-symbol "+ECL-VERSION-NUMBER+" :EXT)))
15 trittweiler 1.60 (when (or (not version) (< (symbol-value version) 100301))
16 trittweiler 1.52 (error "~&IMPORTANT:~% ~
17     The version of ECL you're using (~A) is too old.~% ~
18 trittweiler 1.60 Please upgrade to at least 10.3.1.~% ~
19 trittweiler 1.52 Sorry for the inconvenience.~%~%"
20     (lisp-implementation-version)))))
21    
22 trittweiler 1.53 ;; 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    
35 gcarncross 1.40 (declaim (optimize (debug 3)))
36    
37 trittweiler 1.52 ;;; Swank-mop
38 gcarncross 1.19
39 heller 1.29 (eval-when (:compile-toplevel :load-toplevel :execute)
40 trittweiler 1.52 (import-from :gray *gray-stream-symbols* :swank-backend)
41 sboukarev 1.49
42 trittweiler 1.52 (import-swank-mop-symbols :clos
43 jgarcia 1.75 `(:eql-specializer
44 sboukarev 1.49 :eql-specializer-object
45     :generic-function-declarations
46     :specializer-direct-methods
47 jgarcia 1.75 ,@(unless (fboundp 'clos:compute-applicable-methods-using-classes)
48     '(:compute-applicable-methods-using-classes)))))
49 sboukarev 1.49
50 jgarcia 1.1
51     ;;;; TCP Server
52    
53 trittweiler 1.56 (defimplementation preferred-communication-style ()
54     ;; While ECL does provide threads, some parts of it are not
55     ;; thread-safe (2010-02-23), including the compiler and CLOS.
56     nil
57     ;; ECL on Windows does not provide condition-variables
58     ;; (or #+(and threads (not windows)) :spawn
59     ;; nil)
60     )
61    
62 jgarcia 1.1 (defun resolve-hostname (name)
63     (car (sb-bsd-sockets:host-ent-addresses
64     (sb-bsd-sockets:get-host-by-name name))))
65    
66 heller 1.71 (defimplementation create-socket (host port &key backlog)
67 jgarcia 1.1 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
68     :type :stream
69     :protocol :tcp)))
70     (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
71     (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
72 heller 1.71 (sb-bsd-sockets:socket-listen socket (or backlog 5))
73 jgarcia 1.1 socket))
74    
75     (defimplementation local-port (socket)
76     (nth-value 1 (sb-bsd-sockets:socket-name socket)))
77    
78     (defimplementation close-socket (socket)
79     (sb-bsd-sockets:socket-close socket))
80    
81     (defimplementation accept-connection (socket
82 heller 1.6 &key external-format
83 dcrosher 1.5 buffering timeout)
84 trittweiler 1.53 (declare (ignore timeout))
85 trittweiler 1.52 (sb-bsd-sockets:socket-make-stream (accept socket)
86 jgarcia 1.1 :output t
87     :input t
88 heller 1.70 :buffering (ecase buffering
89     ((t) :full)
90     ((nil) :none)
91     (:line line))
92 sboukarev 1.72 :element-type (if external-format
93     'character
94     '(unsigned-byte 8))
95 trittweiler 1.53 :external-format external-format))
96 jgarcia 1.1 (defun accept (socket)
97     "Like socket-accept, but retry on EAGAIN."
98     (loop (handler-case
99     (return (sb-bsd-sockets:socket-accept socket))
100     (sb-bsd-sockets:interrupted-error ()))))
101    
102 trittweiler 1.56 (defimplementation socket-fd (socket)
103     (etypecase socket
104     (fixnum socket)
105     (two-way-stream (socket-fd (two-way-stream-input-stream socket)))
106     (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
107     (file-stream (si:file-stream-fd socket))))
108 jgarcia 1.1
109 trittweiler 1.44 (defvar *external-format-to-coding-system*
110 trittweiler 1.53 '((:latin-1
111 trittweiler 1.44 "latin-1" "latin-1-unix" "iso-latin-1-unix"
112     "iso-8859-1" "iso-8859-1-unix")
113     (:utf-8 "utf-8" "utf-8-unix")))
114    
115 trittweiler 1.53 (defun external-format (coding-system)
116     (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
117     *external-format-to-coding-system*))
118     (find coding-system (ext:all-encodings) :test #'string-equal)))
119    
120 trittweiler 1.44 (defimplementation find-external-format (coding-system)
121 trittweiler 1.53 #+unicode (external-format coding-system)
122     ;; Without unicode support, ECL uses the one-byte encoding of the
123     ;; underlying OS, and will barf on anything except :DEFAULT. We
124     ;; return NIL here for known multibyte encodings, so
125     ;; SWANK:CREATE-SERVER will barf.
126     #-unicode (let ((xf (external-format coding-system)))
127     (if (member xf '(:utf-8))
128     nil
129     :default)))
130 trittweiler 1.44
131 jgarcia 1.1
132 trittweiler 1.53 ;;;; Unix Integration
133 jgarcia 1.1
134 trittweiler 1.62 ;;; If ECL is built with thread support, it'll spawn a helper thread
135     ;;; executing the SIGINT handler. We do not want to BREAK into that
136     ;;; helper but into the main thread, though. This is coupled with the
137     ;;; current choice of NIL as communication-style in so far as ECL's
138     ;;; main-thread is also the Slime's REPL thread.
139 trittweiler 1.52
140 trittweiler 1.62 (defimplementation call-with-user-break-handler (real-handler function)
141     (let ((old-handler #'si:terminal-interrupt))
142 heller 1.27 (setf (symbol-function 'si:terminal-interrupt)
143 trittweiler 1.62 (make-interrupt-handler real-handler))
144     (unwind-protect (funcall function)
145     (setf (symbol-function 'si:terminal-interrupt) old-handler))))
146    
147     #+threads
148     (defun make-interrupt-handler (real-handler)
149     (let ((main-thread (find 'si:top-level (mp:all-processes)
150     :key #'mp:process-name)))
151     #'(lambda (&rest args)
152     (declare (ignore args))
153     (mp:interrupt-process main-thread real-handler))))
154    
155     #-threads
156     (defun make-interrupt-handler (real-handler)
157     #'(lambda (&rest args)
158     (declare (ignore args))
159     (funcall real-handler)))
160    
161 heller 1.27
162 jgarcia 1.1 (defimplementation getpid ()
163     (si:getpid))
164    
165     (defimplementation set-default-directory (directory)
166 trittweiler 1.52 (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*.
167 jgarcia 1.1 (default-directory))
168    
169     (defimplementation default-directory ()
170     (namestring (ext:getcwd)))
171    
172     (defimplementation quit-lisp ()
173     (ext:quit))
174    
175    
176 trittweiler 1.52
177 trittweiler 1.56 ;;; Instead of busy waiting with communication-style NIL, use select()
178     ;;; on the sockets' streams.
179 trittweiler 1.52 #+serve-event
180     (progn
181 trittweiler 1.56 (defun poll-streams (streams timeout)
182     (let* ((serve-event::*descriptor-handlers*
183     (copy-list serve-event::*descriptor-handlers*))
184     (active-fds '())
185     (fd-stream-alist
186     (loop for s in streams
187     for fd = (socket-fd s)
188 trittweiler 1.64 collect (cons fd s)
189 trittweiler 1.56 do (serve-event:add-fd-handler fd :input
190     #'(lambda (fd)
191     (push fd active-fds))))))
192     (serve-event:serve-event timeout)
193     (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist)))))
194    
195     (defimplementation wait-for-input (streams &optional timeout)
196     (assert (member timeout '(nil t)))
197     (loop
198     (cond ((check-slime-interrupts) (return :interrupt))
199     (timeout (return (poll-streams streams 0)))
200     (t
201 trittweiler 1.57 (when-let (ready (poll-streams streams 0.2))
202     (return ready))))))
203 trittweiler 1.52
204     ) ; #+serve-event (progn ...
205    
206 heller 1.76 #-serve-event
207     (defimplementation wait-for-input (streams &optional timeout)
208     (assert (member timeout '(nil t)))
209     (loop
210     (cond ((check-slime-interrupts) (return :interrupt))
211     (timeout (return (remove-if-not #'listen streams)))
212     (t
213     (let ((ready (remove-if-not #'listen streams)))
214     (if ready (return ready))
215     (sleep 0.1))))))
216    
217 trittweiler 1.52
218 jgarcia 1.1 ;;;; Compilation
219    
220     (defvar *buffer-name* nil)
221     (defvar *buffer-start-position*)
222    
223     (defun signal-compiler-condition (&rest args)
224 sboukarev 1.77 (apply #'signal 'compiler-condition args))
225 jgarcia 1.1
226 jgarcia 1.69 #-ecl-bytecmp
227 trittweiler 1.52 (defun handle-compiler-message (condition)
228     ;; ECL emits lots of noise in compiler-notes, like "Invoking
229     ;; external command".
230     (unless (typep condition 'c::compiler-note)
231     (signal-compiler-condition
232     :original-condition condition
233 trittweiler 1.53 :message (princ-to-string condition)
234 trittweiler 1.52 :severity (etypecase condition
235     (c:compiler-fatal-error :error)
236 trittweiler 1.53 (c:compiler-error :error)
237     (error :error)
238     (style-warning :style-warning)
239     (warning :warning))
240 trittweiler 1.52 :location (condition-location condition))))
241    
242 jgarcia 1.69 #-ecl-bytecmp
243 trittweiler 1.52 (defun condition-location (condition)
244     (let ((file (c:compiler-message-file condition))
245     (position (c:compiler-message-file-position condition)))
246     (if (and position (not (minusp position)))
247     (if *buffer-name*
248 trittweiler 1.56 (make-buffer-location *buffer-name*
249     *buffer-start-position*
250     position)
251 trittweiler 1.53 (make-file-location file position))
252 trittweiler 1.52 (make-error-location "No location found."))))
253 jgarcia 1.1
254     (defimplementation call-with-compilation-hooks (function)
255 jgarcia 1.69 #-ecl-bytecmp
256     (funcall function)
257     #-ecl-bytecmp
258 trittweiler 1.52 (handler-bind ((c:compiler-message #'handle-compiler-message))
259 jgarcia 1.1 (funcall function)))
260    
261 heller 1.38 (defimplementation swank-compile-file (input-file output-file
262 sboukarev 1.58 load-p external-format
263     &key policy)
264     (declare (ignore policy))
265 jgarcia 1.1 (with-compilation-hooks ()
266 trittweiler 1.53 (compile-file input-file :output-file output-file
267     :load load-p
268     :external-format external-format)))
269 jgarcia 1.1
270 trittweiler 1.59 (defvar *tmpfile-map* (make-hash-table :test #'equal))
271    
272     (defun note-buffer-tmpfile (tmp-file buffer-name)
273     ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring.
274     (let ((tmp-namestring (namestring (truename tmp-file))))
275 trittweiler 1.63 (setf (gethash tmp-namestring *tmpfile-map*) buffer-name)
276     tmp-namestring))
277 trittweiler 1.59
278     (defun tmpfile-to-buffer (tmp-file)
279     (gethash tmp-file *tmpfile-map*))
280    
281 heller 1.37 (defimplementation swank-compile-string (string &key buffer position filename
282 trittweiler 1.53 policy)
283 trittweiler 1.59 (declare (ignore policy))
284 jgarcia 1.1 (with-compilation-hooks ()
285 trittweiler 1.53 (let ((*buffer-name* buffer) ; for compilation hooks
286 trittweiler 1.52 (*buffer-start-position* position))
287 trittweiler 1.59 (let ((tmp-file (si:mkstemp "TMP:ecl-swank-tmpfile-"))
288 trittweiler 1.54 (fasl-file)
289     (warnings-p)
290     (failure-p))
291 trittweiler 1.53 (unwind-protect
292 trittweiler 1.59 (with-open-file (tmp-stream tmp-file :direction :output
293     :if-exists :supersede)
294     (write-string string tmp-stream)
295     (finish-output tmp-stream)
296 trittweiler 1.54 (multiple-value-setq (fasl-file warnings-p failure-p)
297 trittweiler 1.59 (compile-file tmp-file
298     :load t
299     :source-truename (or filename
300     (note-buffer-tmpfile tmp-file buffer))
301     :source-offset (1- position))))
302     (when (probe-file tmp-file)
303     (delete-file tmp-file))
304 trittweiler 1.54 (when fasl-file
305     (delete-file fasl-file)))
306     (not failure-p)))))
307 jgarcia 1.1
308     ;;;; Documentation
309    
310     (defimplementation arglist (name)
311 trittweiler 1.56 (multiple-value-bind (arglist foundp)
312 trittweiler 1.57 (ext:function-lambda-list name)
313 trittweiler 1.56 (if foundp arglist :not-available)))
314 jgarcia 1.1
315 heller 1.6 (defimplementation function-name (f)
316 sboukarev 1.48 (typecase f
317     (generic-function (clos:generic-function-name f))
318     (function (si:compiled-function-name f))))
319 jgarcia 1.1
320 trittweiler 1.52 ;; FIXME
321     ;; (defimplementation macroexpand-all (form))
322 jgarcia 1.1
323     (defimplementation describe-symbol-for-emacs (symbol)
324     (let ((result '()))
325     (dolist (type '(:VARIABLE :FUNCTION :CLASS))
326 trittweiler 1.57 (when-let (doc (describe-definition symbol type))
327     (setf result (list* type doc result))))
328 jgarcia 1.1 result))
329    
330     (defimplementation describe-definition (name type)
331     (case type
332     (:variable (documentation name 'variable))
333     (:function (documentation name 'function))
334     (:class (documentation name 'class))
335     (t nil)))
336    
337 trittweiler 1.56
338 jgarcia 1.1 ;;; Debugging
339    
340 heller 1.29 (eval-when (:compile-toplevel :load-toplevel :execute)
341 heller 1.28 (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)))
358 jgarcia 1.1
359 trittweiler 1.52 (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)
373 trittweiler 1.53 (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
374 trittweiler 1.52 (funcall fun)))
375    
376 gcarncross 1.20 (defvar *backtrace* '())
377    
378 trittweiler 1.53 ;;; 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)))))
409 gcarncross 1.21
410 jgarcia 1.1 (defimplementation call-with-debugging-environment (debugger-loop-fn)
411     (declare (type function debugger-loop-fn))
412 trittweiler 1.57 (let* ((*ihs-top* (ihs-top))
413 trittweiler 1.31 (*ihs-current* *ihs-top*)
414     (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
415     (*frs-top* (frs-top))
416     (*tpl-level* (1+ *tpl-level*))
417 gcarncross 1.40 (*backtrace* (loop for ihs from 0 below *ihs-top*
418 gcarncross 1.21 collect (list (si::ihs-fun ihs)
419 gcarncross 1.20 (si::ihs-env ihs)
420     nil))))
421 gcarncross 1.40 (declare (special *ihs-current*))
422 gcarncross 1.20 (loop for f from *frs-base* until *frs-top*
423     do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
424     (when (plusp i)
425     (let* ((x (elt *backtrace* i))
426     (name (si::frs-tag f)))
427 gcarncross 1.23 (unless (si::fixnump name)
428 gcarncross 1.20 (push name (third x)))))))
429 trittweiler 1.53 (setf *backtrace* (nreverse *backtrace*))
430 jgarcia 1.1 (set-break-env)
431     (set-current-ihs)
432 gcarncross 1.20 (let ((*ihs-base* *ihs-top*))
433     (funcall debugger-loop-fn))))
434    
435 jgarcia 1.1 (defimplementation compute-backtrace (start end)
436 gcarncross 1.20 (when (numberp end)
437     (setf end (min end (length *backtrace*))))
438 trittweiler 1.31 (loop for f in (subseq *backtrace* start end)
439 heller 1.35 collect f))
440 gcarncross 1.20
441     (defun frame-name (frame)
442     (let ((x (first frame)))
443     (if (symbolp x)
444     x
445     (function-name x))))
446    
447     (defun function-position (fun)
448     (multiple-value-bind (file position)
449     (si::bc-file fun)
450 trittweiler 1.53 (when file
451     (make-file-location file position))))
452 gcarncross 1.20
453     (defun frame-function (frame)
454     (let* ((x (first frame))
455     fun position)
456     (etypecase x
457     (symbol (and (fboundp x)
458     (setf fun (fdefinition x)
459     position (function-position fun))))
460     (function (setf fun x position (function-position x))))
461     (values fun position)))
462    
463     (defun frame-decode-env (frame)
464     (let ((functions '())
465     (blocks '())
466     (variables '()))
467 trittweiler 1.52 (setf frame (si::decode-ihs-env (second frame)))
468 jgarcia 1.67 (dolist (record (remove-if-not #'consp frame))
469 gcarncross 1.20 (let* ((record0 (car record))
470     (record1 (cdr record)))
471 gcarncross 1.40 (cond ((or (symbolp record0) (stringp record0))
472 gcarncross 1.20 (setq variables (acons record0 record1 variables)))
473 gcarncross 1.23 ((not (si::fixnump record0))
474 gcarncross 1.20 (push record1 functions))
475     ((symbolp record1)
476     (push record1 blocks))
477     (t
478     ))))
479     (values functions blocks variables)))
480 jgarcia 1.1
481 heller 1.35 (defimplementation print-frame (frame stream)
482     (format stream "~A" (first frame)))
483 gcarncross 1.20
484 heller 1.41 (defimplementation frame-source-location (frame-number)
485 gcarncross 1.20 (nth-value 1 (frame-function (elt *backtrace* frame-number))))
486    
487     (defimplementation frame-catch-tags (frame-number)
488     (third (elt *backtrace* frame-number)))
489    
490     (defimplementation frame-locals (frame-number)
491 heller 1.73 (loop for (name . value) in (nth-value 2 (frame-decode-env
492     (elt *backtrace* frame-number)))
493 gcarncross 1.20 with i = 0
494     collect (list :name name :id (prog1 i (incf i)) :value value)))
495    
496     (defimplementation frame-var-value (frame-number var-id)
497     (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
498     var-id))
499    
500     (defimplementation disassemble-frame (frame-number)
501 trittweiler 1.56 (let ((fun (frame-function (elt *backtrace* frame-number))))
502 gcarncross 1.20 (disassemble fun)))
503    
504     (defimplementation eval-in-frame (form frame-number)
505     (let ((env (second (elt *backtrace* frame-number))))
506     (si:eval-with-env form env)))
507 jgarcia 1.1
508 trittweiler 1.65 (defimplementation gdb-initial-commands ()
509     ;; These signals are used by the GC.
510     #+linux '("handle SIGPWR noprint nostop"
511     "handle SIGXCPU noprint nostop"))
512    
513 trittweiler 1.66 (defimplementation command-line-args ()
514     (loop for n from 0 below (si:argc) collect (si:argv n)))
515    
516 trittweiler 1.56
517 jgarcia 1.1 ;;;; Inspector
518    
519 trittweiler 1.56 ;;; FIXME: Would be nice if it was possible to inspect objects
520     ;;; implemented in C.
521 gcarncross 1.11
522 trittweiler 1.56
523 jgarcia 1.1 ;;;; Definitions
524    
525 sboukarev 1.68 (defvar +TAGS+ (namestring
526     (merge-pathnames "TAGS" (translate-logical-pathname "SYS:"))))
527 trittweiler 1.55
528 trittweiler 1.59 (defun make-file-location (file file-position)
529     ;; File positions in CL start at 0, but Emacs' buffer positions
530     ;; start at 1. We specify (:ALIGN T) because the positions comming
531     ;; from ECL point at right after the toplevel form appearing before
532     ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case.
533 trittweiler 1.63 (make-location `(:file ,(namestring (translate-logical-pathname file)))
534 trittweiler 1.59 `(:position ,(1+ file-position))
535     `(:align t)))
536 trittweiler 1.55
537 trittweiler 1.59 (defun make-buffer-location (buffer-name start-position &optional (offset 0))
538     (make-location `(:buffer ,buffer-name)
539     `(:offset ,start-position ,offset)
540     `(:align t)))
541 trittweiler 1.55
542 trittweiler 1.59 (defun make-TAGS-location (&rest tags)
543     (make-location `(:etags-file ,+TAGS+)
544     `(:tag ,@tags)))
545 trittweiler 1.55
546 trittweiler 1.59 (defimplementation find-definitions (name)
547     (let ((annotations (ext:get-annotation name 'si::location :all)))
548     (cond (annotations
549     (loop for annotation in annotations
550     collect (destructuring-bind (dspec file . pos) annotation
551     `(,dspec ,(make-file-location file pos)))))
552     (t
553     (mapcan #'(lambda (type) (find-definitions-by-type name type))
554     (classify-definition-name name))))))
555 trittweiler 1.54
556     (defun classify-definition-name (name)
557     (let ((types '()))
558     (when (fboundp name)
559     (cond ((special-operator-p name)
560     (push :special-operator types))
561     ((macro-function name)
562     (push :macro types))
563     ((typep (fdefinition name) 'generic-function)
564     (push :generic-function types))
565     ((si:mangle-name name t)
566     (push :c-function types))
567     (t
568     (push :lisp-function types))))
569 trittweiler 1.57 (when (boundp name)
570     (cond ((constantp name)
571     (push :constant types))
572     (t
573     (push :global-variable types))))
574 trittweiler 1.54 types))
575    
576 trittweiler 1.57 (defun find-definitions-by-type (name type)
577 trittweiler 1.54 (ecase type
578     (:lisp-function
579 trittweiler 1.57 (when-let (loc (source-location (fdefinition name)))
580     (list `((defun ,name) ,loc))))
581 trittweiler 1.54 (:c-function
582 trittweiler 1.57 (when-let (loc (source-location (fdefinition name)))
583     (list `((c-source ,name) ,loc))))
584 trittweiler 1.54 (:generic-function
585     (loop for method in (clos:generic-function-methods (fdefinition name))
586     for specs = (clos:method-specializers method)
587     for loc = (source-location method)
588     when loc
589     collect `((defmethod ,name ,specs) ,loc)))
590     (:macro
591 trittweiler 1.57 (when-let (loc (source-location (macro-function name)))
592     (list `((defmacro ,name) ,loc))))
593 trittweiler 1.59 (:constant
594     (when-let (loc (source-location name))
595     (list `((defconstant ,name) ,loc))))
596     (:global-variable
597     (when-let (loc (source-location name))
598     (list `((defvar ,name) ,loc))))
599     (:special-operator)))
600 trittweiler 1.54
601 trittweiler 1.59 ;;; FIXME: There ought to be a better way.
602     (eval-when (:compile-toplevel :load-toplevel :execute)
603     (defun c-function-name-p (name)
604     (and (symbolp name) (si:mangle-name name t) t))
605     (defun c-function-p (object)
606     (and (functionp object)
607     (let ((fn-name (function-name object)))
608     (and fn-name (c-function-name-p fn-name))))))
609    
610     (deftype c-function ()
611     `(satisfies c-function-p))
612    
613     (defun assert-source-directory ()
614     (unless (probe-file #P"SRC:")
615     (error "ECL's source directory ~A does not exist. ~
616     You can specify a different location via the environment ~
617     variable `ECLSRCDIR'."
618     (namestring (translate-logical-pathname #P"SYS:")))))
619    
620     (defun assert-TAGS-file ()
621     (unless (probe-file +TAGS+)
622     (error "No TAGS file ~A found. It should have been installed with ECL."
623     +TAGS+)))
624 trittweiler 1.55
625 trittweiler 1.64 (defun package-names (package)
626     (cons (package-name package) (package-nicknames package)))
627    
628 trittweiler 1.54 (defun source-location (object)
629 trittweiler 1.55 (converting-errors-to-error-location
630 trittweiler 1.59 (typecase object
631     (c-function
632     (assert-source-directory)
633     (assert-TAGS-file)
634     (let ((lisp-name (function-name object)))
635     (assert lisp-name)
636     (multiple-value-bind (flag c-name) (si:mangle-name lisp-name t)
637     (assert flag)
638     ;; In ECL's code base sometimes the mangled name is used
639 trittweiler 1.64 ;; directly, sometimes ECL's DPP magic of @SI::SYMBOL or
640     ;; @EXT::SYMBOL is used. We cannot predict here, so we just
641     ;; provide several candidates.
642     (apply #'make-TAGS-location
643     c-name
644     (loop with s = (symbol-name lisp-name)
645     for p in (package-names (symbol-package lisp-name))
646     collect (format nil "~A::~A" p s)
647     collect (format nil "~(~A::~A~)" p s))))))
648 trittweiler 1.59 (function
649     (multiple-value-bind (file pos) (ext:compiled-function-file object)
650     (cond ((not file)
651     (return-from source-location nil))
652 sboukarev 1.61 ((tmpfile-to-buffer file)
653     (make-buffer-location (tmpfile-to-buffer file) pos))
654 trittweiler 1.59 (t
655     (assert (probe-file file))
656     (assert (not (minusp pos)))
657 trittweiler 1.63 (make-file-location file pos)))))
658 trittweiler 1.59 (method
659     ;; FIXME: This will always return NIL at the moment; ECL does not
660     ;; store debug information for methods yet.
661     (source-location (clos:method-function object)))
662     ((member nil t)
663     (multiple-value-bind (flag c-name) (si:mangle-name object)
664     (assert flag)
665     (make-TAGS-location c-name))))))
666 trittweiler 1.54
667     (defimplementation find-source-location (object)
668     (or (source-location object)
669 trittweiler 1.59 (make-error-location "Source definition of ~S not found." object)))
670 gcarncross 1.17
671 trittweiler 1.56
672 gcarncross 1.42 ;;;; Profiling
673    
674 trittweiler 1.52 #+profile
675     (progn
676    
677 gcarncross 1.42 (defimplementation profile (fname)
678     (when fname (eval `(profile:profile ,fname))))
679    
680     (defimplementation unprofile (fname)
681     (when fname (eval `(profile:unprofile ,fname))))
682    
683     (defimplementation unprofile-all ()
684     (profile:unprofile-all)
685     "All functions unprofiled.")
686    
687     (defimplementation profile-report ()
688     (profile:report))
689    
690     (defimplementation profile-reset ()
691     (profile:reset)
692     "Reset profiling counters.")
693    
694     (defimplementation profiled-functions ()
695     (profile:profile))
696    
697 gcarncross 1.43 (defimplementation profile-package (package callers methods)
698     (declare (ignore callers methods))
699     (eval `(profile:profile ,(package-name (find-package package)))))
700 trittweiler 1.53 ) ; #+profile (progn ...
701 gcarncross 1.43
702 trittweiler 1.56
703 trittweiler 1.52 ;;;; Threads
704 gcarncross 1.9
705     #+threads
706     (progn
707 trittweiler 1.52 (defvar *thread-id-counter* 0)
708 trittweiler 1.51
709 trittweiler 1.52 (defparameter *thread-id-map* (make-hash-table))
710 gcarncross 1.9
711 trittweiler 1.52 (defvar *thread-id-map-lock*
712     (mp:make-lock :name "thread id map lock"))
713 gcarncross 1.9
714     (defimplementation spawn (fn &key name)
715 trittweiler 1.52 (mp:process-run-function name fn))
716    
717     (defimplementation thread-id (target-thread)
718     (block thread-id
719     (mp:with-lock (*thread-id-map-lock*)
720     ;; Does TARGET-THREAD have an id already?
721     (maphash (lambda (id thread-pointer)
722     (let ((thread (si:weak-pointer-value thread-pointer)))
723     (cond ((not thread)
724     (remhash id *thread-id-map*))
725     ((eq thread target-thread)
726     (return-from thread-id id)))))
727     *thread-id-map*)
728     ;; TARGET-THREAD not found in *THREAD-ID-MAP*
729     (let ((id (incf *thread-id-counter*))
730     (thread-pointer (si:make-weak-pointer target-thread)))
731     (setf (gethash id *thread-id-map*) thread-pointer)
732     id))))
733 gcarncross 1.9
734     (defimplementation find-thread (id)
735 trittweiler 1.52 (mp:with-lock (*thread-id-map-lock*)
736 trittweiler 1.53 (let* ((thread-ptr (gethash id *thread-id-map*))
737     (thread (and thread-ptr (si:weak-pointer-value thread-ptr))))
738 trittweiler 1.52 (unless thread
739     (remhash id *thread-id-map*))
740     thread)))
741 gcarncross 1.9
742     (defimplementation thread-name (thread)
743     (mp:process-name thread))
744    
745     (defimplementation thread-status (thread)
746 trittweiler 1.52 (if (mp:process-active-p thread)
747     "RUNNING"
748     "STOPPED"))
749 gcarncross 1.9
750     (defimplementation make-lock (&key name)
751 jgarcia 1.74 (mp:make-lock :name name :recursive t))
752 gcarncross 1.9
753     (defimplementation call-with-lock-held (lock function)
754     (declare (type function function))
755     (mp:with-lock (lock) (funcall function)))
756    
757     (defimplementation current-thread ()
758     mp:*current-process*)
759    
760     (defimplementation all-threads ()
761     (mp:all-processes))
762    
763     (defimplementation interrupt-thread (thread fn)
764     (mp:interrupt-process thread fn))
765    
766     (defimplementation kill-thread (thread)
767     (mp:process-kill thread))
768    
769     (defimplementation thread-alive-p (thread)
770     (mp:process-active-p thread))
771    
772 trittweiler 1.52 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
773     (defvar *mailboxes* (list))
774     (declaim (type list *mailboxes*))
775    
776 gcarncross 1.9 (defstruct (mailbox (:conc-name mailbox.))
777 trittweiler 1.52 thread
778     (mutex (mp:make-lock))
779     (cvar (mp:make-condition-variable))
780 gcarncross 1.9 (queue '() :type list))
781    
782     (defun mailbox (thread)
783     "Return THREAD's mailbox."
784 trittweiler 1.52 (mp:with-lock (*mailbox-lock*)
785     (or (find thread *mailboxes* :key #'mailbox.thread)
786     (let ((mb (make-mailbox :thread thread)))
787     (push mb *mailboxes*)
788     mb))))
789 gcarncross 1.9
790     (defimplementation send (thread message)
791 trittweiler 1.52 (let* ((mbox (mailbox thread))
792     (mutex (mailbox.mutex mbox)))
793     (mp:with-lock (mutex)
794 trittweiler 1.51 (setf (mailbox.queue mbox)
795     (nconc (mailbox.queue mbox) (list message)))
796     (mp:condition-variable-broadcast (mailbox.cvar mbox)))))
797    
798     (defimplementation receive-if (test &optional timeout)
799 trittweiler 1.52 (let* ((mbox (mailbox (current-thread)))
800     (mutex (mailbox.mutex mbox)))
801 trittweiler 1.51 (assert (or (not timeout) (eq timeout t)))
802     (loop
803 trittweiler 1.52 (check-slime-interrupts)
804     (mp:with-lock (mutex)
805     (let* ((q (mailbox.queue mbox))
806     (tail (member-if test q)))
807     (when tail
808     (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
809     (return (car tail))))
810     (when (eq timeout t) (return (values nil t)))
811     (mp:condition-variable-timedwait (mailbox.cvar mbox)
812     mutex
813     0.2)))))
814 gcarncross 1.9
815 trittweiler 1.52 ) ; #+threads (progn ...

  ViewVC Help
Powered by ViewVC 1.1.5