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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.19 - (hide annotations)
Thu Apr 24 01:44:10 2008 UTC (5 years, 11 months ago) by gcarncross
Branch: MAIN
Changes since 1.18: +8 -2 lines
basic/simple implementation of find-definitions
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 gcarncross 1.19 (defvar *tmp*)
14    
15 gcarncross 1.15 (if (find-package :gray)
16     (import-from :gray *gray-stream-symbols* :swank-backend)
17     (import-from :ext *gray-stream-symbols* :swank-backend))
18 jgarcia 1.1
19     (swank-backend::import-swank-mop-symbols :clos
20     '(:eql-specializer
21     :eql-specializer-object
22     :generic-function-declarations
23     :specializer-direct-methods
24     :compute-applicable-methods-using-classes))
25    
26    
27     ;;;; TCP Server
28    
29     (require 'sockets)
30    
31     (defun resolve-hostname (name)
32     (car (sb-bsd-sockets:host-ent-addresses
33     (sb-bsd-sockets:get-host-by-name name))))
34    
35     (defimplementation create-socket (host port)
36     (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
37     :type :stream
38     :protocol :tcp)))
39     (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
40     (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
41     (sb-bsd-sockets:socket-listen socket 5)
42     socket))
43    
44     (defimplementation local-port (socket)
45     (nth-value 1 (sb-bsd-sockets:socket-name socket)))
46    
47     (defimplementation close-socket (socket)
48     (sb-bsd-sockets:socket-close socket))
49    
50     (defimplementation accept-connection (socket
51 heller 1.6 &key external-format
52 dcrosher 1.5 buffering timeout)
53 heller 1.7 (declare (ignore buffering timeout external-format))
54     (make-socket-io-stream (accept socket)))
55 jgarcia 1.1
56 heller 1.7 (defun make-socket-io-stream (socket)
57 jgarcia 1.1 (sb-bsd-sockets:socket-make-stream socket
58     :output t
59     :input t
60     :element-type 'base-char))
61    
62     (defun accept (socket)
63     "Like socket-accept, but retry on EAGAIN."
64     (loop (handler-case
65     (return (sb-bsd-sockets:socket-accept socket))
66     (sb-bsd-sockets:interrupted-error ()))))
67    
68     (defimplementation preferred-communication-style ()
69     (values nil))
70    
71    
72     ;;;; Unix signals
73    
74     (defimplementation getpid ()
75     (si:getpid))
76    
77     #+nil
78     (defimplementation set-default-directory (directory)
79     (ext::chdir (namestring directory))
80     ;; Setting *default-pathname-defaults* to an absolute directory
81     ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
82     (setf *default-pathname-defaults* (ext::getcwd))
83     (default-directory))
84    
85     #+nil
86     (defimplementation default-directory ()
87     (namestring (ext:getcwd)))
88    
89     (defimplementation quit-lisp ()
90     (ext:quit))
91    
92    
93     ;;;; Compilation
94    
95     (defvar *buffer-name* nil)
96     (defvar *buffer-start-position*)
97     (defvar *buffer-string*)
98     (defvar *compile-filename*)
99    
100     (defun signal-compiler-condition (&rest args)
101     (signal (apply #'make-condition 'compiler-condition args)))
102    
103     (defun handle-compiler-warning (condition)
104     (signal-compiler-condition
105     :original-condition condition
106     :message (format nil "~A" condition)
107     :severity :warning
108     :location
109     (if *buffer-name*
110     (make-location (list :buffer *buffer-name*)
111     (list :position *buffer-start-position*))
112     ;; ;; compiler::*current-form*
113     ;; (if compiler::*current-function*
114     ;; (make-location (list :file *compile-filename*)
115     ;; (list :function-name
116     ;; (symbol-name
117     ;; (slot-value compiler::*current-function*
118     ;; 'compiler::name))))
119     (list :error "No location found.")
120     ;; )
121     )))
122    
123     (defimplementation call-with-compilation-hooks (function)
124     (handler-bind ((warning #'handle-compiler-warning))
125     (funcall function)))
126    
127     (defimplementation swank-compile-file (*compile-filename* load-p
128 heller 1.7 external-format)
129 jgarcia 1.1 (declare (ignore external-format))
130     (with-compilation-hooks ()
131     (let ((*buffer-name* nil))
132     (multiple-value-bind (fn warn fail)
133     (compile-file *compile-filename*)
134     (when load-p (unless fail (load fn)))))))
135    
136 heller 1.16 (defimplementation swank-compile-string (string &key buffer position directory
137     debug)
138     (declare (ignore directory debug))
139 jgarcia 1.1 (with-compilation-hooks ()
140     (let ((*buffer-name* buffer)
141     (*buffer-start-position* position)
142     (*buffer-string* string))
143     (with-input-from-string (s string)
144     (compile-from-stream s :load t)))))
145    
146     (defun compile-from-stream (stream &rest args)
147     (let ((file (si::mkstemp "TMP:ECLXXXXXX")))
148     (with-open-file (s file :direction :output :if-exists :overwrite)
149     (do ((line (read-line stream nil) (read-line stream nil)))
150 trittweiler 1.8 ((not line))
151 jgarcia 1.1 (write-line line s)))
152     (unwind-protect
153     (apply #'compile-file file args)
154     (delete-file file))))
155    
156    
157     ;;;; Documentation
158    
159     (defimplementation arglist (name)
160     (or (functionp name) (setf name (symbol-function name)))
161     (if (functionp name)
162     (typecase name
163     (generic-function
164     (clos::generic-function-lambda-list name))
165 gcarncross 1.10 (compiled-function
166     ; most of the compiled functions have an Args: line in their docs
167     (with-input-from-string (s (or
168     (si::get-documentation
169     (si:compiled-function-name name) 'function)
170     ""))
171     (do ((line (read-line s nil) (read-line s nil)))
172     ((not line) :not-available)
173     (ignore-errors
174     (if (string= (subseq line 0 6) "Args: ")
175     (return-from nil
176     (read-from-string (subseq line 6))))))))
177     ;
178 jgarcia 1.1 (function
179     (let ((fle (function-lambda-expression name)))
180     (case (car fle)
181     (si:lambda-block (caddr fle))
182     (t :not-available)))))
183     :not-available))
184    
185 heller 1.6 (defimplementation function-name (f)
186 jgarcia 1.1 (si:compiled-function-name f))
187    
188     (defimplementation macroexpand-all (form)
189     ;;; FIXME! This is not the same as a recursive macroexpansion!
190     (macroexpand form))
191    
192     (defimplementation describe-symbol-for-emacs (symbol)
193     (let ((result '()))
194     (dolist (type '(:VARIABLE :FUNCTION :CLASS))
195     (let ((doc (describe-definition symbol type)))
196     (when doc
197     (setf result (list* type doc result)))))
198     result))
199    
200     (defimplementation describe-definition (name type)
201     (case type
202     (:variable (documentation name 'variable))
203     (:function (documentation name 'function))
204     (:class (documentation name 'class))
205     (t nil)))
206    
207     ;;; Debugging
208    
209     (import
210     '(si::*ihs-top*
211     si::*ihs-current*
212     si::*ihs-base*
213     si::*frs-base*
214     si::*frs-top*
215     si::*tpl-commands*
216     si::*tpl-level*
217     si::frs-top
218     si::ihs-top
219     si::sch-frs-base
220     si::set-break-env
221     si::set-current-ihs
222     si::tpl-commands))
223    
224     (defimplementation call-with-debugging-environment (debugger-loop-fn)
225     (declare (type function debugger-loop-fn))
226     (let* ((*tpl-commands* si::tpl-commands)
227     (*ihs-top* (ihs-top 'call-with-debugging-environment))
228     (*ihs-current* *ihs-top*)
229     (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
230     (*frs-top* (frs-top))
231     (*read-suppress* nil)
232     (*tpl-level* (1+ *tpl-level*)))
233     (set-break-env)
234     (set-current-ihs)
235     (funcall debugger-loop-fn)))
236    
237     ;; (defimplementation call-with-debugger-hook (hook fun)
238     ;; (let ((*debugger-hook* hook))
239     ;; (funcall fun)))
240    
241     (defun nth-frame (n)
242     (cond ((>= n *ihs-top* ) nil)
243     (t (- *ihs-top* n))))
244    
245     (defimplementation compute-backtrace (start end)
246     (loop for i from start below end
247     for f = (nth-frame i)
248     while f
249     collect f))
250    
251     (defimplementation print-frame (frame stream)
252     (format stream "~A" (si::ihs-fname frame)))
253    
254     ;;;; Inspector
255    
256 heller 1.13 (defmethod emacs-inspect ((o t))
257 gcarncross 1.11 ; ecl clos support leaves some to be desired
258     (cond
259     ((streamp o)
260 heller 1.14 (list*
261     (format nil "~S is an ordinary stream~%" o)
262 gcarncross 1.11 (append
263     (list
264     "Open for "
265     (cond
266     ((ignore-errors (interactive-stream-p o)) "Interactive")
267     ((and (input-stream-p o) (output-stream-p o)) "Input and output")
268     ((input-stream-p o) "Input")
269     ((output-stream-p o) "Output"))
270     `(:newline) `(:newline))
271     (label-value-line*
272     ("Element type" (stream-element-type o))
273     ("External format" (stream-external-format o)))
274     (ignore-errors (label-value-line*
275     ("Broadcast streams" (broadcast-stream-streams o))))
276     (ignore-errors (label-value-line*
277     ("Concatenated streams" (concatenated-stream-streams o))))
278     (ignore-errors (label-value-line*
279     ("Echo input stream" (echo-stream-input-stream o))))
280     (ignore-errors (label-value-line*
281     ("Echo output stream" (echo-stream-output-stream o))))
282     (ignore-errors (label-value-line*
283     ("Output String" (get-output-stream-string o))))
284     (ignore-errors (label-value-line*
285     ("Synonym symbol" (synonym-stream-symbol o))))
286     (ignore-errors (label-value-line*
287     ("Input stream" (two-way-stream-input-stream o))))
288     (ignore-errors (label-value-line*
289     ("Output stream" (two-way-stream-output-stream o)))))))
290     (t
291     (let* ((cl (si:instance-class o))
292     (slots (clos:class-slots cl)))
293 heller 1.14 (list* (format nil "~S is an instance of class ~A~%"
294 gcarncross 1.11 o (clos::class-name cl))
295     (loop for x in slots append
296     (let* ((name (clos:slot-definition-name x))
297     (value (clos::slot-value o name)))
298     (list
299     (format nil "~S: " name)
300     `(:value ,value)
301     `(:newline)))))))))
302    
303 jgarcia 1.1 ;;;; Definitions
304    
305 gcarncross 1.19 (defimplementation find-definitions (name)
306     (if (fboundp name)
307     (let ((tmp (find-source-location (symbol-function name))))
308     `(((defun ,name) ,tmp)))))
309 gcarncross 1.9
310 gcarncross 1.17 (defimplementation find-source-location (obj)
311 gcarncross 1.19 (setf *tmp* obj)
312 gcarncross 1.17 (or
313     (typecase obj
314     (function
315     (multiple-value-bind (file pos) (ignore-errors (si:bc-file obj))
316     (if (and file pos)
317 gcarncross 1.18 (make-location
318 gcarncross 1.19 `(:file ,(namestring file))
319 gcarncross 1.18 `(:position ,pos)
320     `(:snippet
321     ,(with-open-file (s file)
322     (skip-toplevel-forms pos s)
323     (skip-comments-and-whitespace s)
324     (read-snippet s))))))))
325 gcarncross 1.17 `(:error (format nil "Source definition of ~S not found" obj))))
326    
327 gcarncross 1.9 ;;;; Threads
328    
329     #+threads
330     (progn
331     (defvar *thread-id-counter* 0)
332    
333     (defvar *thread-id-counter-lock*
334     (mp:make-lock :name "thread id counter lock"))
335    
336     (defun next-thread-id ()
337     (mp:with-lock (*thread-id-counter-lock*)
338     (incf *thread-id-counter*)))
339    
340     (defparameter *thread-id-map* (make-hash-table))
341    
342     (defvar *thread-id-map-lock*
343     (mp:make-lock :name "thread id map lock"))
344    
345     ; ecl doesn't have weak pointers
346     (defimplementation spawn (fn &key name)
347     (let ((thread (mp:make-process :name name))
348     (id (next-thread-id)))
349     (mp:process-preset
350     thread
351     #'(lambda ()
352     (unwind-protect
353     (mp:with-lock (*thread-id-map-lock*)
354     (setf (gethash id *thread-id-map*) thread))
355     (funcall fn)
356     (mp:with-lock (*thread-id-map-lock*)
357     (remhash id *thread-id-map*)))))
358     (mp:process-enable thread)))
359    
360     (defimplementation thread-id (thread)
361     (block thread-id
362     (mp:with-lock (*thread-id-map-lock*)
363     (loop for id being the hash-key in *thread-id-map*
364     using (hash-value thread-pointer)
365     do (if (eq thread thread-pointer)
366     (return-from thread-id id))))))
367    
368     (defimplementation find-thread (id)
369     (mp:with-lock (*thread-id-map-lock*)
370     (gethash id *thread-id-map*)))
371    
372     (defimplementation thread-name (thread)
373     (mp:process-name thread))
374    
375     (defimplementation thread-status (thread)
376     (if (mp:process-active-p thread)
377     "RUNNING"
378     "STOPPED"))
379    
380     (defimplementation make-lock (&key name)
381     (mp:make-lock :name name))
382    
383     (defimplementation call-with-lock-held (lock function)
384     (declare (type function function))
385     (mp:with-lock (lock) (funcall function)))
386    
387     (defimplementation make-recursive-lock (&key name)
388     (mp:make-lock :name name))
389    
390     (defimplementation call-with-recursive-lock-held (lock function)
391     (declare (type function function))
392     (mp:with-lock (lock) (funcall function)))
393    
394     (defimplementation current-thread ()
395     mp:*current-process*)
396    
397     (defimplementation all-threads ()
398     (mp:all-processes))
399    
400     (defimplementation interrupt-thread (thread fn)
401     (mp:interrupt-process thread fn))
402    
403     (defimplementation kill-thread (thread)
404     (mp:process-kill thread))
405    
406     (defimplementation thread-alive-p (thread)
407     (mp:process-active-p thread))
408    
409     (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
410    
411     (defstruct (mailbox (:conc-name mailbox.))
412     (mutex (mp:make-lock :name "process mailbox"))
413     (queue '() :type list))
414    
415     (defun mailbox (thread)
416     "Return THREAD's mailbox."
417     (mp:with-lock (*mailbox-lock*)
418     (or (find thread *mailboxes* :key #'mailbox.thread)
419     (let ((mb (make-mailbox :thread thread)))
420     (push mb *mailboxes*)
421     mb))))
422    
423     (defimplementation send (thread message)
424     (let* ((mbox (mailbox thread))
425     (mutex (mailbox.mutex mbox)))
426     (mp:interrupt-process
427     thread
428     (lambda ()
429     (mp:with-lock (mutex)
430     (setf (mailbox.queue mbox)
431     (nconc (mailbox.queue mbox) (list message))))))))
432    
433     (defimplementation receive ()
434     (block got-mail
435     (let* ((mbox (mailbox mp:*current-process*))
436     (mutex (mailbox.mutex mbox)))
437     (loop
438     (mp:with-lock (mutex)
439     (if (mailbox.queue mbox)
440     (return-from got-mail (pop (mailbox.queue mbox)))))
441     ;interrupt-process will halt this if it takes longer than 1sec
442     (sleep 1)))))
443    
444     ;; Auto-flush streams
445     (defvar *auto-flush-interval* 0.15
446     "How often to flush interactive streams. This valu is passed
447     directly to cl:sleep.")
448    
449     (defvar *auto-flush-lock* (make-recursive-lock :name "auto flush"))
450    
451     (defvar *auto-flush-thread* nil)
452    
453     (defvar *auto-flush-streams* '())
454    
455     (defimplementation make-stream-interactive (stream)
456     (call-with-recursive-lock-held
457     *auto-flush-lock*
458     (lambda ()
459     (pushnew stream *auto-flush-streams*)
460     (unless *auto-flush-thread*
461     (setq *auto-flush-thread*
462     (spawn #'flush-streams
463     :name "auto-flush-thread"))))))
464    
465     (defmethod stream-finish-output ((stream stream))
466     (finish-output stream))
467    
468     (defun flush-streams ()
469     (loop
470     (call-with-recursive-lock-held
471     *auto-flush-lock*
472     (lambda ()
473     (setq *auto-flush-streams*
474     (remove-if (lambda (x)
475     (not (and (open-stream-p x)
476     (output-stream-p x))))
477     *auto-flush-streams*))
478 gcarncross 1.18 (dolist (i *auto-flush-streams*)
479     (ignore-errors (stream-finish-output i))
480     (ignore-errors (finish-output i)))))
481 gcarncross 1.9 (sleep *auto-flush-interval*)))
482    
483     )
484    

  ViewVC Help
Powered by ViewVC 1.1.5