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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.80 - (hide annotations)
Mon Jan 7 10:12:09 2013 UTC (15 months, 1 week ago) by heller
Branch: MAIN
Changes since 1.79: +7 -3 lines
* swank-ecl.lisp (describe-symbol-for-emacs): Include bound
symbols even those without documentation.

* slime.el (slime-print-apropos): Do some input validation to
detect bugs on the Lisp side.

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

  ViewVC Help
Powered by ViewVC 1.1.5