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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.55 - (hide annotations)
Mon Feb 22 21:43:31 2010 UTC (4 years, 1 month ago) by trittweiler
Branch: MAIN
Changes since 1.54: +57 -52 lines
	Make swank-ecl.lisp work with latest ECL Git HEAD.

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

  ViewVC Help
Powered by ViewVC 1.1.5