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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5