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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.75 - (hide annotations)
Fri Apr 20 21:58:18 2012 UTC (23 months, 3 weeks ago) by jgarcia
Branch: MAIN
Changes since 1.74: +3 -2 lines
In swank-ecl.lisp, import compute-applicable-methods-using-classes when its fboundp (ECL 12.5.1 will provide it).
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    
207 jgarcia 1.1 ;;;; Compilation
208    
209     (defvar *buffer-name* nil)
210     (defvar *buffer-start-position*)
211    
212     (defun signal-compiler-condition (&rest args)
213     (signal (apply #'make-condition 'compiler-condition args)))
214    
215 jgarcia 1.69 #-ecl-bytecmp
216 trittweiler 1.52 (defun handle-compiler-message (condition)
217     ;; ECL emits lots of noise in compiler-notes, like "Invoking
218     ;; external command".
219     (unless (typep condition 'c::compiler-note)
220     (signal-compiler-condition
221     :original-condition condition
222 trittweiler 1.53 :message (princ-to-string condition)
223 trittweiler 1.52 :severity (etypecase condition
224     (c:compiler-fatal-error :error)
225 trittweiler 1.53 (c:compiler-error :error)
226     (error :error)
227     (style-warning :style-warning)
228     (warning :warning))
229 trittweiler 1.52 :location (condition-location condition))))
230    
231 jgarcia 1.69 #-ecl-bytecmp
232 trittweiler 1.52 (defun condition-location (condition)
233     (let ((file (c:compiler-message-file condition))
234     (position (c:compiler-message-file-position condition)))
235     (if (and position (not (minusp position)))
236     (if *buffer-name*
237 trittweiler 1.56 (make-buffer-location *buffer-name*
238     *buffer-start-position*
239     position)
240 trittweiler 1.53 (make-file-location file position))
241 trittweiler 1.52 (make-error-location "No location found."))))
242 jgarcia 1.1
243     (defimplementation call-with-compilation-hooks (function)
244 jgarcia 1.69 #-ecl-bytecmp
245     (funcall function)
246     #-ecl-bytecmp
247 trittweiler 1.52 (handler-bind ((c:compiler-message #'handle-compiler-message))
248 jgarcia 1.1 (funcall function)))
249    
250 heller 1.38 (defimplementation swank-compile-file (input-file output-file
251 sboukarev 1.58 load-p external-format
252     &key policy)
253     (declare (ignore policy))
254 jgarcia 1.1 (with-compilation-hooks ()
255 trittweiler 1.53 (compile-file input-file :output-file output-file
256     :load load-p
257     :external-format external-format)))
258 jgarcia 1.1
259 trittweiler 1.59 (defvar *tmpfile-map* (make-hash-table :test #'equal))
260    
261     (defun note-buffer-tmpfile (tmp-file buffer-name)
262     ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring.
263     (let ((tmp-namestring (namestring (truename tmp-file))))
264 trittweiler 1.63 (setf (gethash tmp-namestring *tmpfile-map*) buffer-name)
265     tmp-namestring))
266 trittweiler 1.59
267     (defun tmpfile-to-buffer (tmp-file)
268     (gethash tmp-file *tmpfile-map*))
269    
270 heller 1.37 (defimplementation swank-compile-string (string &key buffer position filename
271 trittweiler 1.53 policy)
272 trittweiler 1.59 (declare (ignore policy))
273 jgarcia 1.1 (with-compilation-hooks ()
274 trittweiler 1.53 (let ((*buffer-name* buffer) ; for compilation hooks
275 trittweiler 1.52 (*buffer-start-position* position))
276 trittweiler 1.59 (let ((tmp-file (si:mkstemp "TMP:ecl-swank-tmpfile-"))
277 trittweiler 1.54 (fasl-file)
278     (warnings-p)
279     (failure-p))
280 trittweiler 1.53 (unwind-protect
281 trittweiler 1.59 (with-open-file (tmp-stream tmp-file :direction :output
282     :if-exists :supersede)
283     (write-string string tmp-stream)
284     (finish-output tmp-stream)
285 trittweiler 1.54 (multiple-value-setq (fasl-file warnings-p failure-p)
286 trittweiler 1.59 (compile-file tmp-file
287     :load t
288     :source-truename (or filename
289     (note-buffer-tmpfile tmp-file buffer))
290     :source-offset (1- position))))
291     (when (probe-file tmp-file)
292     (delete-file tmp-file))
293 trittweiler 1.54 (when fasl-file
294     (delete-file fasl-file)))
295     (not failure-p)))))
296 jgarcia 1.1
297     ;;;; Documentation
298    
299     (defimplementation arglist (name)
300 trittweiler 1.56 (multiple-value-bind (arglist foundp)
301 trittweiler 1.57 (ext:function-lambda-list name)
302 trittweiler 1.56 (if foundp arglist :not-available)))
303 jgarcia 1.1
304 heller 1.6 (defimplementation function-name (f)
305 sboukarev 1.48 (typecase f
306     (generic-function (clos:generic-function-name f))
307     (function (si:compiled-function-name f))))
308 jgarcia 1.1
309 trittweiler 1.52 ;; FIXME
310     ;; (defimplementation macroexpand-all (form))
311 jgarcia 1.1
312     (defimplementation describe-symbol-for-emacs (symbol)
313     (let ((result '()))
314     (dolist (type '(:VARIABLE :FUNCTION :CLASS))
315 trittweiler 1.57 (when-let (doc (describe-definition symbol type))
316     (setf result (list* type doc result))))
317 jgarcia 1.1 result))
318    
319     (defimplementation describe-definition (name type)
320     (case type
321     (:variable (documentation name 'variable))
322     (:function (documentation name 'function))
323     (:class (documentation name 'class))
324     (t nil)))
325    
326 trittweiler 1.56
327 jgarcia 1.1 ;;; Debugging
328    
329 heller 1.29 (eval-when (:compile-toplevel :load-toplevel :execute)
330 heller 1.28 (import
331     '(si::*break-env*
332     si::*ihs-top*
333     si::*ihs-current*
334     si::*ihs-base*
335     si::*frs-base*
336     si::*frs-top*
337     si::*tpl-commands*
338     si::*tpl-level*
339     si::frs-top
340     si::ihs-top
341     si::ihs-fun
342     si::ihs-env
343     si::sch-frs-base
344     si::set-break-env
345     si::set-current-ihs
346     si::tpl-commands)))
347 jgarcia 1.1
348 trittweiler 1.52 (defun make-invoke-debugger-hook (hook)
349     (when hook
350     #'(lambda (condition old-hook)
351     ;; Regard *debugger-hook* if set by user.
352     (if *debugger-hook*
353     nil ; decline, *DEBUGGER-HOOK* will be tried next.
354     (funcall hook condition old-hook)))))
355    
356     (defimplementation install-debugger-globally (function)
357     (setq *debugger-hook* function)
358     (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
359    
360     (defimplementation call-with-debugger-hook (hook fun)
361     (let ((*debugger-hook* hook)
362 trittweiler 1.53 (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
363 trittweiler 1.52 (funcall fun)))
364    
365 gcarncross 1.20 (defvar *backtrace* '())
366    
367 trittweiler 1.53 ;;; Commented out; it's not clear this is a good way of doing it. In
368     ;;; particular because it makes errors stemming from this file harder
369     ;;; to debug, and given the "young" age of ECL's swank backend, that's
370     ;;; a bad idea.
371    
372     ;; (defun in-swank-package-p (x)
373     ;; (and
374     ;; (symbolp x)
375     ;; (member (symbol-package x)
376     ;; (list #.(find-package :swank)
377     ;; #.(find-package :swank-backend)
378     ;; #.(ignore-errors (find-package :swank-mop))
379     ;; #.(ignore-errors (find-package :swank-loader))))
380     ;; t))
381    
382     ;; (defun is-swank-source-p (name)
383     ;; (setf name (pathname name))
384     ;; (pathname-match-p
385     ;; name
386     ;; (make-pathname :defaults swank-loader::*source-directory*
387     ;; :name (pathname-name name)
388     ;; :type (pathname-type name)
389     ;; :version (pathname-version name))))
390    
391     ;; (defun is-ignorable-fun-p (x)
392     ;; (or
393     ;; (in-swank-package-p (frame-name x))
394     ;; (multiple-value-bind (file position)
395     ;; (ignore-errors (si::bc-file (car x)))
396     ;; (declare (ignore position))
397     ;; (if file (is-swank-source-p file)))))
398 gcarncross 1.21
399 jgarcia 1.1 (defimplementation call-with-debugging-environment (debugger-loop-fn)
400     (declare (type function debugger-loop-fn))
401 trittweiler 1.57 (let* ((*ihs-top* (ihs-top))
402 trittweiler 1.31 (*ihs-current* *ihs-top*)
403     (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
404     (*frs-top* (frs-top))
405     (*tpl-level* (1+ *tpl-level*))
406 gcarncross 1.40 (*backtrace* (loop for ihs from 0 below *ihs-top*
407 gcarncross 1.21 collect (list (si::ihs-fun ihs)
408 gcarncross 1.20 (si::ihs-env ihs)
409     nil))))
410 gcarncross 1.40 (declare (special *ihs-current*))
411 gcarncross 1.20 (loop for f from *frs-base* until *frs-top*
412     do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
413     (when (plusp i)
414     (let* ((x (elt *backtrace* i))
415     (name (si::frs-tag f)))
416 gcarncross 1.23 (unless (si::fixnump name)
417 gcarncross 1.20 (push name (third x)))))))
418 trittweiler 1.53 (setf *backtrace* (nreverse *backtrace*))
419 jgarcia 1.1 (set-break-env)
420     (set-current-ihs)
421 gcarncross 1.20 (let ((*ihs-base* *ihs-top*))
422     (funcall debugger-loop-fn))))
423    
424 jgarcia 1.1 (defimplementation compute-backtrace (start end)
425 gcarncross 1.20 (when (numberp end)
426     (setf end (min end (length *backtrace*))))
427 trittweiler 1.31 (loop for f in (subseq *backtrace* start end)
428 heller 1.35 collect f))
429 gcarncross 1.20
430     (defun frame-name (frame)
431     (let ((x (first frame)))
432     (if (symbolp x)
433     x
434     (function-name x))))
435    
436     (defun function-position (fun)
437     (multiple-value-bind (file position)
438     (si::bc-file fun)
439 trittweiler 1.53 (when file
440     (make-file-location file position))))
441 gcarncross 1.20
442     (defun frame-function (frame)
443     (let* ((x (first frame))
444     fun position)
445     (etypecase x
446     (symbol (and (fboundp x)
447     (setf fun (fdefinition x)
448     position (function-position fun))))
449     (function (setf fun x position (function-position x))))
450     (values fun position)))
451    
452     (defun frame-decode-env (frame)
453     (let ((functions '())
454     (blocks '())
455     (variables '()))
456 trittweiler 1.52 (setf frame (si::decode-ihs-env (second frame)))
457 jgarcia 1.67 (dolist (record (remove-if-not #'consp frame))
458 gcarncross 1.20 (let* ((record0 (car record))
459     (record1 (cdr record)))
460 gcarncross 1.40 (cond ((or (symbolp record0) (stringp record0))
461 gcarncross 1.20 (setq variables (acons record0 record1 variables)))
462 gcarncross 1.23 ((not (si::fixnump record0))
463 gcarncross 1.20 (push record1 functions))
464     ((symbolp record1)
465     (push record1 blocks))
466     (t
467     ))))
468     (values functions blocks variables)))
469 jgarcia 1.1
470 heller 1.35 (defimplementation print-frame (frame stream)
471     (format stream "~A" (first frame)))
472 gcarncross 1.20
473 heller 1.41 (defimplementation frame-source-location (frame-number)
474 gcarncross 1.20 (nth-value 1 (frame-function (elt *backtrace* frame-number))))
475    
476     (defimplementation frame-catch-tags (frame-number)
477     (third (elt *backtrace* frame-number)))
478    
479     (defimplementation frame-locals (frame-number)
480 heller 1.73 (loop for (name . value) in (nth-value 2 (frame-decode-env
481     (elt *backtrace* frame-number)))
482 gcarncross 1.20 with i = 0
483     collect (list :name name :id (prog1 i (incf i)) :value value)))
484    
485     (defimplementation frame-var-value (frame-number var-id)
486     (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
487     var-id))
488    
489     (defimplementation disassemble-frame (frame-number)
490 trittweiler 1.56 (let ((fun (frame-function (elt *backtrace* frame-number))))
491 gcarncross 1.20 (disassemble fun)))
492    
493     (defimplementation eval-in-frame (form frame-number)
494     (let ((env (second (elt *backtrace* frame-number))))
495     (si:eval-with-env form env)))
496 jgarcia 1.1
497 trittweiler 1.65 (defimplementation gdb-initial-commands ()
498     ;; These signals are used by the GC.
499     #+linux '("handle SIGPWR noprint nostop"
500     "handle SIGXCPU noprint nostop"))
501    
502 trittweiler 1.66 (defimplementation command-line-args ()
503     (loop for n from 0 below (si:argc) collect (si:argv n)))
504    
505 trittweiler 1.56
506 jgarcia 1.1 ;;;; Inspector
507    
508 trittweiler 1.56 ;;; FIXME: Would be nice if it was possible to inspect objects
509     ;;; implemented in C.
510 gcarncross 1.11
511 trittweiler 1.56
512 jgarcia 1.1 ;;;; Definitions
513    
514 sboukarev 1.68 (defvar +TAGS+ (namestring
515     (merge-pathnames "TAGS" (translate-logical-pathname "SYS:"))))
516 trittweiler 1.55
517 trittweiler 1.59 (defun make-file-location (file file-position)
518     ;; File positions in CL start at 0, but Emacs' buffer positions
519     ;; start at 1. We specify (:ALIGN T) because the positions comming
520     ;; from ECL point at right after the toplevel form appearing before
521     ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case.
522 trittweiler 1.63 (make-location `(:file ,(namestring (translate-logical-pathname file)))
523 trittweiler 1.59 `(:position ,(1+ file-position))
524     `(:align t)))
525 trittweiler 1.55
526 trittweiler 1.59 (defun make-buffer-location (buffer-name start-position &optional (offset 0))
527     (make-location `(:buffer ,buffer-name)
528     `(:offset ,start-position ,offset)
529     `(:align t)))
530 trittweiler 1.55
531 trittweiler 1.59 (defun make-TAGS-location (&rest tags)
532     (make-location `(:etags-file ,+TAGS+)
533     `(:tag ,@tags)))
534 trittweiler 1.55
535 trittweiler 1.59 (defimplementation find-definitions (name)
536     (let ((annotations (ext:get-annotation name 'si::location :all)))
537     (cond (annotations
538     (loop for annotation in annotations
539     collect (destructuring-bind (dspec file . pos) annotation
540     `(,dspec ,(make-file-location file pos)))))
541     (t
542     (mapcan #'(lambda (type) (find-definitions-by-type name type))
543     (classify-definition-name name))))))
544 trittweiler 1.54
545     (defun classify-definition-name (name)
546     (let ((types '()))
547     (when (fboundp name)
548     (cond ((special-operator-p name)
549     (push :special-operator types))
550     ((macro-function name)
551     (push :macro types))
552     ((typep (fdefinition name) 'generic-function)
553     (push :generic-function types))
554     ((si:mangle-name name t)
555     (push :c-function types))
556     (t
557     (push :lisp-function types))))
558 trittweiler 1.57 (when (boundp name)
559     (cond ((constantp name)
560     (push :constant types))
561     (t
562     (push :global-variable types))))
563 trittweiler 1.54 types))
564    
565 trittweiler 1.57 (defun find-definitions-by-type (name type)
566 trittweiler 1.54 (ecase type
567     (:lisp-function
568 trittweiler 1.57 (when-let (loc (source-location (fdefinition name)))
569     (list `((defun ,name) ,loc))))
570 trittweiler 1.54 (:c-function
571 trittweiler 1.57 (when-let (loc (source-location (fdefinition name)))
572     (list `((c-source ,name) ,loc))))
573 trittweiler 1.54 (:generic-function
574     (loop for method in (clos:generic-function-methods (fdefinition name))
575     for specs = (clos:method-specializers method)
576     for loc = (source-location method)
577     when loc
578     collect `((defmethod ,name ,specs) ,loc)))
579     (:macro
580 trittweiler 1.57 (when-let (loc (source-location (macro-function name)))
581     (list `((defmacro ,name) ,loc))))
582 trittweiler 1.59 (:constant
583     (when-let (loc (source-location name))
584     (list `((defconstant ,name) ,loc))))
585     (:global-variable
586     (when-let (loc (source-location name))
587     (list `((defvar ,name) ,loc))))
588     (:special-operator)))
589 trittweiler 1.54
590 trittweiler 1.59 ;;; FIXME: There ought to be a better way.
591     (eval-when (:compile-toplevel :load-toplevel :execute)
592     (defun c-function-name-p (name)
593     (and (symbolp name) (si:mangle-name name t) t))
594     (defun c-function-p (object)
595     (and (functionp object)
596     (let ((fn-name (function-name object)))
597     (and fn-name (c-function-name-p fn-name))))))
598    
599     (deftype c-function ()
600     `(satisfies c-function-p))
601    
602     (defun assert-source-directory ()
603     (unless (probe-file #P"SRC:")
604     (error "ECL's source directory ~A does not exist. ~
605     You can specify a different location via the environment ~
606     variable `ECLSRCDIR'."
607     (namestring (translate-logical-pathname #P"SYS:")))))
608    
609     (defun assert-TAGS-file ()
610     (unless (probe-file +TAGS+)
611     (error "No TAGS file ~A found. It should have been installed with ECL."
612     +TAGS+)))
613 trittweiler 1.55
614 trittweiler 1.64 (defun package-names (package)
615     (cons (package-name package) (package-nicknames package)))
616    
617 trittweiler 1.54 (defun source-location (object)
618 trittweiler 1.55 (converting-errors-to-error-location
619 trittweiler 1.59 (typecase object
620     (c-function
621     (assert-source-directory)
622     (assert-TAGS-file)
623     (let ((lisp-name (function-name object)))
624     (assert lisp-name)
625     (multiple-value-bind (flag c-name) (si:mangle-name lisp-name t)
626     (assert flag)
627     ;; In ECL's code base sometimes the mangled name is used
628 trittweiler 1.64 ;; directly, sometimes ECL's DPP magic of @SI::SYMBOL or
629     ;; @EXT::SYMBOL is used. We cannot predict here, so we just
630     ;; provide several candidates.
631     (apply #'make-TAGS-location
632     c-name
633     (loop with s = (symbol-name lisp-name)
634     for p in (package-names (symbol-package lisp-name))
635     collect (format nil "~A::~A" p s)
636     collect (format nil "~(~A::~A~)" p s))))))
637 trittweiler 1.59 (function
638     (multiple-value-bind (file pos) (ext:compiled-function-file object)
639     (cond ((not file)
640     (return-from source-location nil))
641 sboukarev 1.61 ((tmpfile-to-buffer file)
642     (make-buffer-location (tmpfile-to-buffer file) pos))
643 trittweiler 1.59 (t
644     (assert (probe-file file))
645     (assert (not (minusp pos)))
646 trittweiler 1.63 (make-file-location file pos)))))
647 trittweiler 1.59 (method
648     ;; FIXME: This will always return NIL at the moment; ECL does not
649     ;; store debug information for methods yet.
650     (source-location (clos:method-function object)))
651     ((member nil t)
652     (multiple-value-bind (flag c-name) (si:mangle-name object)
653     (assert flag)
654     (make-TAGS-location c-name))))))
655 trittweiler 1.54
656     (defimplementation find-source-location (object)
657     (or (source-location object)
658 trittweiler 1.59 (make-error-location "Source definition of ~S not found." object)))
659 gcarncross 1.17
660 trittweiler 1.56
661 gcarncross 1.42 ;;;; Profiling
662    
663 trittweiler 1.52 #+profile
664     (progn
665    
666 gcarncross 1.42 (defimplementation profile (fname)
667     (when fname (eval `(profile:profile ,fname))))
668    
669     (defimplementation unprofile (fname)
670     (when fname (eval `(profile:unprofile ,fname))))
671    
672     (defimplementation unprofile-all ()
673     (profile:unprofile-all)
674     "All functions unprofiled.")
675    
676     (defimplementation profile-report ()
677     (profile:report))
678    
679     (defimplementation profile-reset ()
680     (profile:reset)
681     "Reset profiling counters.")
682    
683     (defimplementation profiled-functions ()
684     (profile:profile))
685    
686 gcarncross 1.43 (defimplementation profile-package (package callers methods)
687     (declare (ignore callers methods))
688     (eval `(profile:profile ,(package-name (find-package package)))))
689 trittweiler 1.53 ) ; #+profile (progn ...
690 gcarncross 1.43
691 trittweiler 1.56
692 trittweiler 1.52 ;;;; Threads
693 gcarncross 1.9
694     #+threads
695     (progn
696 trittweiler 1.52 (defvar *thread-id-counter* 0)
697 trittweiler 1.51
698 trittweiler 1.52 (defparameter *thread-id-map* (make-hash-table))
699 gcarncross 1.9
700 trittweiler 1.52 (defvar *thread-id-map-lock*
701     (mp:make-lock :name "thread id map lock"))
702 gcarncross 1.9
703     (defimplementation spawn (fn &key name)
704 trittweiler 1.52 (mp:process-run-function name fn))
705    
706     (defimplementation thread-id (target-thread)
707     (block thread-id
708     (mp:with-lock (*thread-id-map-lock*)
709     ;; Does TARGET-THREAD have an id already?
710     (maphash (lambda (id thread-pointer)
711     (let ((thread (si:weak-pointer-value thread-pointer)))
712     (cond ((not thread)
713     (remhash id *thread-id-map*))
714     ((eq thread target-thread)
715     (return-from thread-id id)))))
716     *thread-id-map*)
717     ;; TARGET-THREAD not found in *THREAD-ID-MAP*
718     (let ((id (incf *thread-id-counter*))
719     (thread-pointer (si:make-weak-pointer target-thread)))
720     (setf (gethash id *thread-id-map*) thread-pointer)
721     id))))
722 gcarncross 1.9
723     (defimplementation find-thread (id)
724 trittweiler 1.52 (mp:with-lock (*thread-id-map-lock*)
725 trittweiler 1.53 (let* ((thread-ptr (gethash id *thread-id-map*))
726     (thread (and thread-ptr (si:weak-pointer-value thread-ptr))))
727 trittweiler 1.52 (unless thread
728     (remhash id *thread-id-map*))
729     thread)))
730 gcarncross 1.9
731     (defimplementation thread-name (thread)
732     (mp:process-name thread))
733    
734     (defimplementation thread-status (thread)
735 trittweiler 1.52 (if (mp:process-active-p thread)
736     "RUNNING"
737     "STOPPED"))
738 gcarncross 1.9
739     (defimplementation make-lock (&key name)
740 jgarcia 1.74 (mp:make-lock :name name :recursive t))
741 gcarncross 1.9
742     (defimplementation call-with-lock-held (lock function)
743     (declare (type function function))
744     (mp:with-lock (lock) (funcall function)))
745    
746     (defimplementation current-thread ()
747     mp:*current-process*)
748    
749     (defimplementation all-threads ()
750     (mp:all-processes))
751    
752     (defimplementation interrupt-thread (thread fn)
753     (mp:interrupt-process thread fn))
754    
755     (defimplementation kill-thread (thread)
756     (mp:process-kill thread))
757    
758     (defimplementation thread-alive-p (thread)
759     (mp:process-active-p thread))
760    
761 trittweiler 1.52 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
762     (defvar *mailboxes* (list))
763     (declaim (type list *mailboxes*))
764    
765 gcarncross 1.9 (defstruct (mailbox (:conc-name mailbox.))
766 trittweiler 1.52 thread
767     (mutex (mp:make-lock))
768     (cvar (mp:make-condition-variable))
769 gcarncross 1.9 (queue '() :type list))
770    
771     (defun mailbox (thread)
772     "Return THREAD's mailbox."
773 trittweiler 1.52 (mp:with-lock (*mailbox-lock*)
774     (or (find thread *mailboxes* :key #'mailbox.thread)
775     (let ((mb (make-mailbox :thread thread)))
776     (push mb *mailboxes*)
777     mb))))
778 gcarncross 1.9
779     (defimplementation send (thread message)
780 trittweiler 1.52 (let* ((mbox (mailbox thread))
781     (mutex (mailbox.mutex mbox)))
782     (mp:with-lock (mutex)
783 trittweiler 1.51 (setf (mailbox.queue mbox)
784     (nconc (mailbox.queue mbox) (list message)))
785     (mp:condition-variable-broadcast (mailbox.cvar mbox)))))
786    
787     (defimplementation receive-if (test &optional timeout)
788 trittweiler 1.52 (let* ((mbox (mailbox (current-thread)))
789     (mutex (mailbox.mutex mbox)))
790 trittweiler 1.51 (assert (or (not timeout) (eq timeout t)))
791     (loop
792 trittweiler 1.52 (check-slime-interrupts)
793     (mp:with-lock (mutex)
794     (let* ((q (mailbox.queue mbox))
795     (tail (member-if test q)))
796     (when tail
797     (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
798     (return (car tail))))
799     (when (eq timeout t) (return (values nil t)))
800     (mp:condition-variable-timedwait (mailbox.cvar mbox)
801     mutex
802     0.2)))))
803 gcarncross 1.9
804 trittweiler 1.52 ) ; #+threads (progn ...

  ViewVC Help
Powered by ViewVC 1.1.5