[usocket-cvs] r594 - usocket/branches/0.5.x/backend
Chun Tian (binghe)
ctian at common-lisp.net
Mon Mar 28 23:09:39 UTC 2011
Author: ctian
Date: Mon Mar 28 19:09:39 2011
New Revision: 594
Log:
[SBCL] change the use of WITH-TIMEOUT into a nested version for safe purpose.
Modified:
usocket/branches/0.5.x/backend/sbcl.lisp
Modified: usocket/branches/0.5.x/backend/sbcl.lisp
==============================================================================
--- usocket/branches/0.5.x/backend/sbcl.lisp (original)
+++ usocket/branches/0.5.x/backend/sbcl.lisp Mon Mar 28 19:09:39 2011
@@ -210,6 +210,22 @@
(close stream)
stream))
+;;; A nested version of SB-EXT:WITH-TIMEOUT, from GBBopen's portable-threads.
+;;; I belive the author is Dan Corkill. -- binghe, 2011-3-29
+
+#+sbcl
+(defmacro %with-timeout ((seconds &body timeout-body) &body timed-body)
+ (let ((tag-sym (gensym))
+ (timer-sym (gensym)))
+ `(block ,tag-sym
+ (let ((,timer-sym
+ (sb-ext:make-timer
+ #'(lambda ()
+ (return-from ,tag-sym (progn , at timeout-body))))))
+ (sb-ext:schedule-timer ,timer-sym ,seconds)
+ (unwind-protect (progn , at timed-body)
+ (sb-ext:unschedule-timer ,timer-sym))))))
+
(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
timeout deadline (nodelay t nodelay-specified)
local-host local-port
@@ -254,7 +270,7 @@
(labels ((connect ()
(sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port)))
(if timeout
- (sb-ext:with-timeout timeout (connect))
+ (%with-timeout (timeout (error 'sb-ext:timeout)) (connect))
(connect)))
#+ecl
(sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port)
More information about the usocket-cvs
mailing list