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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5