diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm index 20bffef..efeec8d 100644 --- a/scheme/httpd/surflets/packages.scm +++ b/scheme/httpd/surflets/packages.scm @@ -261,7 +261,8 @@ load-structure)) (define-interface with-locks-interface - (export with-lock)) + (export with-lock* + (with-lock :syntax))) ;; With the help of TYPED-OPTIONALS you can define a function ;; like (make-submit-button [string] args) diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm index 7931671..99f2c8f 100644 --- a/scheme/httpd/surflets/surflet-handler.scm +++ b/scheme/httpd/surflets/surflet-handler.scm @@ -134,16 +134,15 @@ (< (cdr p) (cdr q))))) (let lp () (with-lock *session-table-lock* - (lambda () - (let ((now (time))) - (let lp2 () - (receive (session-id.time ignore) (search-tree-min *timeout-queue*) - (if session-id.time - (if (<= (cdr session-id.time) now) - (let ((session-id (car session-id.time))) - (table-set! *session-table* session-id #f) - (pop-search-tree-min! *timeout-queue*) - (lp2))))))))) + (let ((now (time))) + (let lp2 () + (receive (session-id.time ignore) (search-tree-min *timeout-queue*) + (if session-id.time + (if (<= (cdr session-id.time) now) + (let ((session-id (car session-id.time))) + (table-set! *session-table* session-id #f) + (pop-search-tree-min! *timeout-queue*) + (lp2)))))))) (sleep 1000) (lp))) @@ -322,13 +321,12 @@ (define (really-session-adjust-timeout! session-id time-to-live) (with-lock *session-table-lock* - (lambda () - (let ((session (table-ref *session-table* session-id))) - (if session - (timeout-queue-adjust-session-timeout! - session-id - (+ (time) time-to-live)) - (error "There is no session with this ID" session-id)))))) + (let ((session (table-ref *session-table* session-id))) + (if session + (timeout-queue-adjust-session-timeout! + session-id + (+ (time) time-to-live)) + (error "There is no session with this ID" session-id))))) ;;; ADJUST-TIMEOUT! ;; Resets time-to-die of current session. The argument must be diff --git a/scheme/httpd/surflets/with-locks.scm b/scheme/httpd/surflets/with-locks.scm index a3b6181..7e5324c 100644 --- a/scheme/httpd/surflets/with-locks.scm +++ b/scheme/httpd/surflets/with-locks.scm @@ -1,6 +1,6 @@ ;; From sunterlib -(define (with-lock lock thunk) +(define (with-lock* lock thunk) (dynamic-wind (lambda () (obtain-lock lock)) @@ -8,3 +8,8 @@ (lambda () (release-lock lock)))) +(define-syntax with-lock + (syntax-rules () + ((with-lock lock body ...) + (with-lock* lock (lambda () body ...))))) + \ No newline at end of file