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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5